SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00042 SORTING ROUTINES 1 05-28-9313:57ALL SWAG SUPPORT TEAM ALPHAREC.PAS IMPORT 7 S¼═ { Alphabetic Rec Sort }ππProcedure SortIt(Key : Byte);πVarπ I, J : Byte;ππProcedure Swapper;πVarπ T : Member;ππbeginπ T := Memrec[I];π MemRec[I] := MemRec[J];π MemRec[J] := T;πend;ππbeginπ For I := 1 to MaxMem - 1 DOπ For J := I To MaxMem do beginπ Case Key OFπ 1 : if MemRec[I].Firstname < MemRec[J].FirstName then Swapper;π 2 : if MemRec[I].LastName < MemRec[J].LastName then Swapper;π 3 : if MemRec[I].Points < MemRec[J].Points then Swapper;π end;πend;ππ{πAnother Alternative would be to do as C does, make a Generic Sort routineπwhere you pass it a Function that returns > 0 if Record1 is greater thanπRecord2, < 0 if Record1 is Less than Record2, and 0 if they are the same.π}π 2 05-28-9313:57ALL GUY MCLOUGHLIN Anangram Sort IMPORT 196 S└j (* Start of PART 1 of 7 *)ππ(***********************************************************************π Contest 3 Entry : Anagram Sort by Guy McLoughlinπ Compiler : Borland Pascal 7.0π***********************************************************************)ππ {.$DEFINE DebugMode}ππ {$IFDEF DebugMode}π {$A+,B-,D+,E-,F-,G+,I+,L+,N-,O-,P-,Q+,R+,S+,T+,V+,X-}π {$ELSE}π {$A+,B-,D-,E-,F-,G+,I-,L-,N-,O-,P-,Q-,R-,S+,T-,V-,X-}π {$endIF}ππ {$M 16384,374784,655360}ππProgram Anagram_Sort;ππConstπ co_MaxWord = 2500;π co_MaxSize = 65519;π co_SafeSize = 64500;ππTypeπ Char_12 = Array[1..12] of Char;ππ st_4 = String[4];π st_10 = String[10];π st_80 = String[80];ππ byar_26 = Array[97..122] of Byte;ππ po_Buff = ^byar_Buffer;π byar_Buffer = Array[1..co_MaxSize] of Byte;ππ porc_Word = ^rc_Word;π rc_Word = Recordπ wo_Pos : Word;π ar_LtrChk : Char_12;π st_Word : st_10π end;ππ poar_Word = Array[0..co_MaxWord] of porc_Word;ππ porc_AnaGroup = ^rc_AnaGroup;π rc_AnaGroup = Recordπ wo_Pos : Word;π st_Group : st_80π end;ππ poar_AnaGroup = Array[0..co_MaxWord] of porc_AnaGroup;π poar_Generic = Array[0..co_MaxWord] of Pointer;ππ (***** Check For I/O errors. *)π (* *)π Procedure CheckIOerror;π Varπ by_Error : Byte;π beginπ by_Error := ioresult;π if (by_Error <> 0) thenπ beginπ Writeln('Input/Output error = ', by_Error);π haltπ endπ end; (* CheckIOerror. *)ππ (***** Display HEAP error message. *)π (* *)π Procedure HeapError;π beginπ Writeln('Insuficient free HEAP memory');π haltπ end; (* HeapError. *)ππTypeπ Item = Pointer;π ar_Item = poar_Generic;π CompFunc = Function(Var Item1, Item2 : Item) : Boolean;ππ (* end of PART 1 of 7 *)π (* Start of PART 2 of 7 *)ππ (***** QuickSort routine. *)π (* *)π Procedure QuickSort({update} Var ar_Data : ar_Item;π {input } wo_Left,π wo_Right : Word;π LessThan : CompFunc);π Varπ Pivot,π TempItem : Item;π wo_Index1,π wo_Index2 : Word;π beginπ wo_Index1 := wo_Left;π wo_Index2 := wo_Right;π Pivot := ar_Data[(wo_Left + wo_Right) div 2];π Repeatπ While LessThan(ar_Data[wo_Index1], Pivot) doπ inc(wo_Index1);π While LessThan(Pivot, ar_Data[wo_Index2]) doπ dec(wo_Index2);π if (wo_Index1 <= wo_Index2) thenπ beginπ TempItem := ar_Data[wo_Index1];π ar_Data[wo_Index1] := ar_Data[wo_Index2];π ar_Data[wo_Index2] := TempItem;π inc(wo_Index1);π dec(wo_Index2)π endπ Until (wo_Index1 > wo_Index2);π if (wo_Left < wo_Index2) thenπ QuickSort(ar_Data, wo_Left, wo_Index2, LessThan);π if (wo_Index1 < wo_Right) thenπ QuickSort(ar_Data, wo_Index1, wo_Right, LessThan)π end; (* QuickSort. *)ππ (***** Sort Function to check if anagram-Word's are in sorted order *)π (* *)π Function AlphaSort(Var Item1, Item2 : Item) : Boolean; Far;π beginπ AlphaSort := (porc_Word(Item1)^.st_Word < porc_Word(Item2)^.st_Word)π end; (* AlphaSort. *)ππ (***** Sort Function to check: *)π (* *)π (* 1 - If anagram-Words are sorted by length. *)π (* 2 - If anagram-Words are sorted by anagram-group. *)π (* 3- If anagram-Words are sorted alphabeticly. *)π (* *)π Function Sort1(Var Item1, Item2 : Item) : Boolean; Far;π beginπ if (porc_Word(Item1)^.st_Word[0] <>π porc_Word(Item2)^.st_Word[0]) thenπ Sort1 := (porc_Word(Item1)^.st_Word[0] <π porc_Word(Item2)^.st_Word[0])π elseπ if (porc_Word(Item1)^.ar_LtrChk <>π porc_Word(Item2)^.ar_LtrChk) thenπ Sort1 := (porc_Word(Item1)^.ar_LtrChk <π porc_Word(Item2)^.ar_LtrChk)π elseπ Sort1 := (porc_Word(Item1)^.wo_Pos < porc_Word(Item2)^.wo_Pos)π end; (* Sort1. *)ππ (***** Sort Function to check: *)π (* *)π (* If anagram-group Strings are sorted alphabeticly. *)π (* *)π Function Sort2(Var Item1, Item2 : Item) : Boolean; Far;π beginπ Sort2 := (porc_AnaGroup(Item1)^.wo_Pos <π porc_AnaGroup(Item2)^.wo_Pos)π end; (* Sort2. *)ππ (* end of PART 2 of 7 *)π (* Start of PART 3 of 7 *)ππ (***** Check if the anagram-Word table is in sorted order. *)π (* *)π Function TableSorted({input } Var ar_Data : poar_Word;π wo_Left,π wo_Right : Word) : {output} Boolean;π Varπ wo_Index : Word;π beginπ (* Set Function result to True. *)π TableSorted := True;ππ (* Loop through all but the last Word in the anagram- *)π (* Word "table". *)π For wo_Index := wo_Left to pred(wo_Right) doπ (* Check if the current and next anagram-Words are not *)π (* sorted. *)π if (ar_Data[wo_Index]^.st_Word >π ar_Data[succ(wo_Index)]^.st_Word) thenπ beginπ (* Set Function result to False, and break the "for" *)π (* loop. *)π TableSorted := False;π breakπ endπ end; (* TableSorted. *)ππ (***** Pack bits 0,1,2 of each Byte in 26 Byte Array into 10 Chars. *)π (* *)π Procedure PackBits({input } Var byar_Temp : byar_26;π {output} Var Char_Temp : Char_12);π beginπ Char_Temp[ 1] := chr((byar_Temp[ 97] and $7) shl 5 +π (byar_Temp[ 98] and $7) shl 2 +π (byar_Temp[ 99] and $6) shr 1);π Char_Temp[ 2] := chr((byar_Temp[ 99] and $1) shl 7 +π (byar_Temp[100] and $7) shl 4 +π (byar_Temp[101] and $7) shl 1 +π (byar_Temp[102] and $4) shr 2);π Char_Temp[ 3] := chr((byar_Temp[102] and $3) shl 6 +π (byar_Temp[103] and $7) shl 3 +π (byar_Temp[104] and $7));π Char_Temp[ 4] := chr((byar_Temp[105] and $7) shl 5 +π (byar_Temp[106] and $7) shl 2 +π (byar_Temp[107] and $6) shr 1);π Char_Temp[ 5] := chr((byar_Temp[107] and $1) shl 7 +π (byar_Temp[108] and $7) shl 4 +π (byar_Temp[109] and $7) shl 1 +π (byar_Temp[110] and $4) shr 2);π Char_Temp[ 6] := chr((byar_Temp[110] and $3) shl 6 +π (byar_Temp[111] and $7) shl 3 +π (byar_Temp[112] and $7));π Char_Temp[ 7] := chr((byar_Temp[113] and $7) shl 5 +π (byar_Temp[114] and $7) shl 2 +π (byar_Temp[115] and $6) shr 1);π Char_Temp[ 8] := chr((byar_Temp[115] and $1) shl 7 +π (byar_Temp[116] and $7) shl 4 +π (byar_Temp[117] and $7) shl 1 +π (byar_Temp[118] and $4) shr 2);π Char_Temp[ 9] := chr((byar_Temp[118] and $3) shl 6 +π (byar_Temp[119] and $7) shl 3 +π (byar_Temp[120] and $7));π Char_Temp[10] := chr((byar_Temp[121] and $7) shl 5 +π (byar_Temp[122] and $7) shl 2)π end; (* PackBits. *)ππVarπ po_Buffer : po_Buff;ππ by_Index,π by_LastAnagram,π by_CurrentWord : Byte;ππ wo_Index,π wo_ReadIndex,π wo_TableIndex,π wo_BufferIndex,π wo_CurrentIndex : Word;ππ (* end of PART 3 of 7 *)π (* Start of PART 4 of 7 *)ππ st_Temp : st_4;ππ byar_LtrChk : byar_26;ππ fi_Temp : File;ππ rcar_Table : poar_Word;ππ rcar_Groups : poar_AnaGroup;πππ (* Main Program execution block. *)πbeginπ (* If there is sufficient room, allocate the main data- *)π (* buffer on the HEAP. *)π if (maxavail > co_MaxSize) thenπ new(po_Buffer)π elseπ (* Else, inform user of insufficient HEAP memory, and *)π (* halt the Program. *)π HeapError;ππ (* Clear the data-buffer. *)π fillChar(po_Buffer^, co_MaxSize, 0);ππ (* Initialize counter Variable. *)π wo_Index := 0;ππ (* While the counter is less than co_MaxWord do... *)π While (co_MaxWord > wo_Index) doππ (* If there is sufficient memory, allocate another *)π (* anagram-Word Record on the HEAP. *)π if (maxavail > sizeof(rc_Word)) thenπ beginπ inc(wo_Index);π new(rcar_Table[wo_Index]);π fillChar(rcar_Table[wo_Index]^, sizeof(rc_Word), 0);π endπ elseπ (* Else, inform user of insufficient HEAP memory, and *)π (* halt the Program. *)π HeapError;ππ (* Initialize counter Variable. *)π wo_Index := 0;ππ (* While the counter is less than co_MaxWord do... *)π While (co_MaxWord > wo_Index) doππ (* If there is sufficient memory, allocate another *)π (* anagram-group String on the HEAP. *)π if (maxavail > sizeof(rc_AnaGroup)) thenπ beginπ inc(wo_Index);π new(rcar_Groups[wo_Index]);π fillChar(rcar_Groups[wo_Index]^, sizeof(rc_AnaGroup), 32);π endπ elseπ (* Else, inform user of insufficient HEAP memory, and *)π (* halt the Program. *)π HeapError;ππ (* Attempt to open File containing the anagram-Words. *)π assign(fi_Temp, 'WordLIST.DAT');ππ (* Set Filemode to "read-only". *)π Filemode := 0;π {$I-}π reset(fi_Temp, 1);π {$I+}π (* Check For I/O errors. *)π if (ioresult <> 0) thenπ beginπ Writeln('Error opening anagram data File ---> WordLIST.DAT');π haltπ end;π (* Read-in the entire anagram list into the data-buffer *)π blockread(fi_Temp, po_Buffer^, co_MaxSize, wo_ReadIndex);ππ (* end of PART 4 of 7 *)π (* Start of PART 5 of 7 *)ππ (* Check For I/O errors. *)π CheckIOerror;ππ close(fi_Temp);ππ (* Check For I/O errors. *)π CheckIOerror;ππ (* Initialize index Variables. *)π wo_TableIndex := 0;π wo_BufferIndex := 0;ππ (* Repeat...Until all data in the data-buffer has been *)π (* processed. *)π Repeatππ (* Repeat...Until a valid anagram-Word Character has *)π (* been found, or the complete data-buffer has been *)π (* processed. *)π Repeatπ inc(wo_BufferIndex)π Until ((po_Buffer^[wo_BufferIndex] > 96)π and (po_Buffer^[wo_BufferIndex] < 123))π or (wo_BufferIndex > wo_ReadIndex);ππ (* If the complete data-buffer has been processed then *)π (* break the Repeat...Until loop. *)π if (wo_BufferIndex > wo_ReadIndex) thenπ break;ππ (* Advance the anagram-Word "table" index. *)π inc(wo_TableIndex);ππ (* Clear the "letter check" Byte-Array Variable. *)π fillChar(byar_LtrChk, sizeof(byar_26), 0);ππ (* Repeat...Until not an anagram-Word Character, or *)π (* complete data-buffer has been processed. *)π Repeatππ (* With the current anagram-Word Record do... *)π With rcar_Table[wo_TableIndex]^ doπ beginπ (* Record the number of each alphabetical Character in *)π (* the anagram-Word. *)π inc(byar_LtrChk[po_Buffer^[wo_BufferIndex]]);ππ (* Advance the String length-Character. *)π inc(st_Word[0]);ππ (* Add the current anagram-Word Character to anagram- *)π (* Word String. *)π st_Word[ord(st_Word[0])] :=π chr(po_Buffer^[wo_BufferIndex]);ππ (* Advance the data-buffer index. *)π inc(wo_BufferIndex)ππ endπ Until (po_Buffer^[wo_BufferIndex] < 97)π or (po_Buffer^[wo_BufferIndex] > 122)π or (wo_BufferIndex > wo_ReadIndex);ππ (* Pack bits 0,1,2 of each Character in "letter-check" *)π (* Variable, to store Variable as 10 Char data. This *)π (* reduces memory storage requirements by 16 Bytes For *)π (* each anagram-Word, and makes data faster to sort. *)π PackBits(byar_LtrChk, rcar_Table[wo_TableIndex]^.ar_LtrChk);ππ Until (wo_BufferIndex > wo_ReadIndex);ππ (* Check if the Array of anagram-Words in the "table" *)π (* Array are sorted. If not then sort them. *)π if not TableSorted(rcar_Table, 1, wo_TableIndex) thenπ QuickSort(poar_Generic(rcar_Table), 1, wo_TableIndex, AlphaSort);ππ (* Record the position of all the anagram-Words on the *)π (* "table" Array. This will be used as a faster sorting *)π (* index. *)π For wo_Index := 1 to wo_TableIndex doπ rcar_Table[wo_Index]^.wo_Pos := wo_Index;ππ (* end of PART 5 of 7 *)π (* Start of PART 6 of 7 *)ππ (* QuickSort the "table" of anagram Words, using Sort1 *)π (* routine. *)π QuickSort(poar_Generic(rcar_Table), 1, wo_TableIndex, Sort1);ππ (* Attempt to open a File to Write sorted data to. *)π assign(fi_Temp, 'SORTED.DAT');π {$I-}π reWrite(fi_Temp, 1);ππ (* Check For I/O errors. *)π CheckIOerror;ππ (* Set the temporary String to ', ' + Cr + Lf. *)π st_Temp := ', ' + #13#10;ππ (* Reset the loop index. *)π wo_Index := 1;ππ (* Repeat...Until all anagram-Word on "table" Array are *)π (* processed. *)π Repeatππ (* Reset the counter Variables. *)π by_LastAnagram := 0;π by_CurrentWord := 0;ππ (* While the next anagram-Word belongs to the same *)π (* anagram-group, advance the by_LastAnagram Variable. *)π While (rcar_Table[(wo_Index + by_LastAnagram)]^.ar_LtrChk =π rcar_Table[succ(wo_Index + by_LastAnagram)]^.ar_LtrChk) doπ inc(by_LastAnagram);ππ (* Repeat...Until next anagram-Word is not in the same *)π (* anagram group. *)π Repeatππ (* With current anagram group do... *)π With rcar_Groups[(wo_Index + by_CurrentWord)]^ doπ beginππ (* Move the first anagram-Word in "table" Array to the *)π (* current anagram group-String. *)π move(rcar_Table[(wo_Index + by_CurrentWord)]^.st_Word[1],π st_Group[1], ord(rcar_Table[(wo_Index +π by_CurrentWord)]^.st_Word[0]));ππ (* Set the length-Char of current anagram-String to 12. *)π st_Group[0] := #12;ππ (* Record the first anagram-Word position. *)π wo_Pos := rcar_Table[(wo_Index + by_CurrentWord)]^.wo_Pos;ππ (* Loop from 0 to total number of anagrams in the group *)π For by_Index := 0 to by_LastAnagram doππ (* If the loop index is not equal the the current *)π (* anagram-Word, then... *)π if (by_Index <> by_CurrentWord) thenπ beginππ (* Add the next anagram-Word to the anagram-String. *)π move(rcar_Table[(wo_Index + by_Index)]^.st_Word[1],π st_Group[succ(length(st_Group))],π ord(rcar_Table[(wo_Index +π by_Index)]^.st_Word[0]));ππ (* Record the length of the anagram-Word added to the *)π (* anagram-String. *)π inc(st_Group[0],π ord(rcar_Table[(wo_Index +π by_Index)]^.st_Word[0]));ππ (* If the current anagram-Word is not the last anagram- *)π (* Word of the anagram-group, and the loop-index is *)π (* less than the last anagram-Word, or the loop-index *)π (* is less than the 2nd to last anagram-Word in group *)π if ((by_CurrentWord <> by_LastAnagram) andπ (by_Index < by_LastAnagram))π or (by_Index < pred(by_LastAnagram)) thenπ beginππ (* end of PART 6 of 7 *)π (* Start of PART 7 of 7 *)ππ (* Add the comma and space Character to anagram-String. *)π move(st_Temp[1],π st_Group[succ(length(st_Group))], 2);π inc(st_Group[0], 2)π endπ end;ππ (* Add the CR + Lf to anagram String. *)π move(st_Temp[3], st_Group[succ(length(st_Group))], 2);π inc(st_Group[0], 2);ππ (* Advance the currrent anagram-Word index. *)π inc(by_CurrentWord)ππ endπ Until (by_CurrentWord > by_LastAnagram);ππ (* Advance the anagram-group index by the current *)π (* anagram-Word index. *)π inc(wo_Index, by_CurrentWord);ππ Until (wo_Index > wo_TableIndex);ππ (* QuickSort the anagram-Strings, using Sort2. *)π QuickSort(poar_Generic(rcar_Groups), 1, wo_TableIndex, Sort2);ππ (* Initialize loop control Variable. *)π wo_CurrentIndex := 1;ππ (* Repeat Until all the anagram Words in the "table" *)π (* Array have been processed. *)π Repeatππ (* Initialize loop control Variable. *)π wo_BufferIndex := 1;ππ (* Place all the anagram-Strings in the data-buffer. *)π While (wo_CurrentIndex <= wo_TableIndex)π and (wo_BufferIndex < co_SafeSize) doπ With rcar_Groups[wo_CurrentIndex]^ doπ beginπ (* Place current anagram-String in the data-buffer. *)π move(st_Group[1], po_Buffer^[wo_BufferIndex],π length(st_Group));ππ (* Advance the data-buffer index by length of anagram- *)π (* String. *)π inc(wo_BufferIndex, length(st_Group));ππ (* Advance current anagram-String index. *)π inc(wo_CurrentIndex)ππ end;ππ (* Write the anagram Text data in the buffer to disk. *)π blockWrite(fi_Temp, po_Buffer^[1], pred(wo_BufferIndex));ππ (* Check For I/O errors. *)π CheckIOerror;ππ Until (wo_CurrentIndex >= wo_TableIndex);ππ (* Close the sorted anagram-Text File. *)π close(fi_Temp);ππ (* Check For I/O errors. *)π CheckIOerrorππend.ππ (* end of PART 7 of 7 *)π{ Hi, to All:ππ ...I gather that the 3rd Programming contest (Anagram Word sort)π is officially over, and am now posting my entry's source-code.ππ This Program should execute in well under 1 second on a 486-33π ram-disk. (It's about 3.21 sec on my 386sx-25) The final compiledπ size of the .EXE is 7360 Bytes.ππ ...I've commented the h*ll out of my source-code, so it's a bitπ on the big side.ππ ...Here is a "quick" run-down of how it works:ππ 1- Creates a 60K buffer on the HEAP.ππ 2- Creates an Array table to store all the anagram Wordsπ and data about each Word, on the HEAP.ππ 3- Creates an Array of anagram-group Strings on the HEAP.ππ 4- Read the entire anagram-Word input File WordLIST.DATπ into the 60K buffer in 1 big chunk.ππ 5- Finds all the anagram-Words in the buffer, and assignsπ their data to the anagram-Word table on the HEAP.ππ 6- Each letter of every anagram-Word is Recorded in anπ Array of 26 Bytes. Then the first 3 bits of each ofπ the 26 Bytes is packed, so that this data can beπ stored in a 10 Character Array in each anagram-Wordπ table Record. (The bits are packed to save space andπ to make the sorting faster.) This method allows forπ a maximum of 7 of the same letter in each Word, whichπ should be sufficient For this contest.ππ 7- The table of anagram Records is then checked to see ifπ the anagram-Words are in sorted order. (In this contestπ the original input File is in sorted order.) If they areπ not in sorted order, QuickSort is called to put theπ Words (actually Pointers to the Words) in order.ππ 8- Now that the anagram-Words are in sorted order, theirπ position in the anagram-Word table is Recorded in aπ position field within each anagram-Word Record.ππ 9- The table of anagram-Word Records is now sorted usingπ a multi-key QuickSort. This will sort the anagram-Wordπ Records by:π 1- Length of anagram-Word.π 2- Letters that each anagram-Word contains.π 3- Alphabeticly.ππ ...This multi-key sort will establish the anagram groups,π and sort the members of each group alphabeticly.ππ 10- Open the sorted output File.ππ 11- Create N number of anagram-Strings from N mumber of anagram-π Words in each anagram-group. Keeping the anagram Words inπ the String in sorted order.ππ 12- QuickSort the anagram-group Strings into alphabetical order.ππ 13- Place all the sorted anagram-group Strings back into theπ 60K buffer.ππ 14- Write the entire buffer to the SORTED.DAT File, and closeπ this File.ππ NOTES: Well this is the first time I've figured out how to doπ multi-key QuickSorts, which I wasn't sure was possibleπ at first.ππ I also tried using a 32-bit CRC value to identify theπ anagram-groups which ran even faster, but should notπ be considered a "safe" method, as it's accuracy is onlyπ guaranteed For 2-7 Character Words.ππ File I/O and repetitive loops are usually the big speedπ killers in these Types of contests, so I always try toπ keep them to a minimum.ππ ...My entry could possibly be tweaked further still,π but I've got a life. <g>ππ} 3 05-28-9313:57ALL SWAG SUPPORT TEAM ANAGRAM2.PAS IMPORT 125 Shó { ANAGRAM. --------------------------------------------------------------------π Raphaël Vanney, 01/93ππ Purpose : Reads a list of Words 4 to 10 Characters long from a Fileπ named 'LIST.#1', outputs a list of anagrams founds in aπ specified format to a File named 'ANAGRAM.RES'.ππ Note : I commented-out the source using a langage, say English, whichπ I'm not Really fluent in ; please forgive mistakes.π------------------------------------------------------------------------------}ππ{$m 8192,65536,655360}π{$a+,d+,e-,f-,g+,i+,l+,n-,o-,q-,r-,s-,v+}ππ{$b-} { Turns off complete Boolean evaluation ; this allows easiestπ combined Boolean tests. }ππUses Crt,π Objects ;ππConstπ MaxWordLen = 10 ; { Offically specified by GP ! }π CntAnagrams : Word = 0 ; { Actually, this counter shows the }π { number of Words found in the }π { output File. }π OutFileName = 'ANAGRAM.RES' ;πππType TWordString = String[MaxWordLen] ;ππ { TWordCollection.π This Object will be used to store the Words in a sorted fashion. Asπ long as the input list is already sorted, it could have inheritedπ from TCollection, put there is no big penalty using a sorted one. }ππ TWordCollection =π Object (TSortedCollection)π Function KeyOf(Item : Pointer) : Pointer ; Virtual ;π Function Compare(Key1, Key2 : Pointer) : Integer ; Virtual ;π Procedure FreeItem(Item : Pointer) ; Virtual ;π end ;π PWordCollection = ^TWordCollection ;ππ { TWord.π This is the Object we'll use to store a Word. Each Word knows :π - it's 'Textual form' : Itπ - the first of it's anagrams, if it has been found to be theπ anagram of another Word,π - the next of it's anagrams, in the same condition. }ππ PWord = ^TWord ;π TWord =π Objectπ It : TWordString ;π FirstAng : PWord ;π NextAng : PWord ;ππ Constructor Init(Var Wrd : TWordString) ;π Destructor Done ;π end ;ππVar WordsList : PWordCollection ; { The main list of Words }π OrgMem : LongInt ; { Original MemAvail }π UsedMem : LongInt ; { Amount of RAM used }ππ{-------------------------------------- TWord --------------------------------}ππConstructor TWord.Init ;πbeginπ It:=Wrd ;π FirstAng:=Nil ;π NextAng:=Nil ;πend ;ππDestructor TWord.Done ;πbeginπend ;ππ{-------------------------------------- TWordCollection ----------------------}π{ The following methods are not commented out, since they already are inπ Turbo-Pascal's documentations, and they do nothing unusual. }ππFunction TWordCollection.KeyOf ;πbeginπ KeyOf:=Addr(PWord(Item)^.It) ;πend ;ππFunction TWordCollection.Compare ;πVar k1 : PString Absolute Key1 ;π k2 : PString Absolute Key2 ;πbeginπ If k1^>k2^π Then Compare:=1π Else If k1^<k2^π Then Compare:=-1π Else Compare:=0 ;πend ;ππProcedure TWordCollection.FreeItem ;πbeginπ Dispose(PWord(Item), Done) ;πend ;ππ{-------------------------------------- Utilities ----------------------------}ππProcedure CleanUp(Var Wrd : TWordString) ;π{ Cleans-up a Word, in Case there would be dirty Characters in the input File }πVar i : Integer ;πbeginπ { Removes trailing spaces ; not afraid of empty Strings }π While Wrd[Length(Wrd)]=' ' Do Dec(Wrd[0]) ;π { Removes any suspect Character }π i:=1 ;π While (i<=Length(Wrd)) Doπ beginπ If Wrd[i]<#33 Then Delete(Wrd, i, 1)π Else Inc(i) ;π end ;πend ;ππFunction PadStr(St : TWordString ; Len : Integer) : String ;π{ Returns a String padded With spaces, of the specified length }πVar i : Integer ;π Tmp : String ;πbeginπ Tmp:=St ;π For i:=Length(Tmp)+1 To Len Do Tmp[i]:=' ' ;π Tmp[0]:=Chr(Len) ;π PadStr:=Tmp ;πend ;ππ{-----------------------------------------------------------------------------}ππFunction AreAnagrams(Var WordA, WordB : TWordString) : Boolean ;π{ Tells whether two Words are anagrams of each other ; assumes the Wordsπ are 'clean' (No Up/Low Case checking, no dirty Characters...)ππ Optimizing hint : Passing parameters by address _greatly_ enhances overallπ speed ; anyway, we'll use a local copy of one of the two, since the usedπ algorithms needs to modify one of the two Words. }ππAssembler ;πVar WordC : TWordString ; { Local copy of WordB }πAsmπ Push DS { Let's save the Data segment... }π LDS SI, WordA { Load WordA's address in ES:DI }π Mov AL, [SI] { Load length Byte into AL }π LDS SI, WordB { Load WordB's address }π Cmp AL, [SI] { Compare lengthes }π JNE @NotAng { <>lengthes, not anagrams }ππ LDS SI, WordBππ { Let's make a local copy of WordB ; enhanced version of TP's "Move" }π ClD { Clear direction flag }π Push SSπ Pop ES { Segment part of WordC's address }π LEA DI, WordC { Offset part of it }π Mov CL, DS:[SI] { Get length Byte }π XOr CH, CH { Make it a Word }π Mov DL, CL { Save length For later use }π Inc CX { # of Bytes to store the String }π ShR CX, 1 { We'll copy Words ; CF is importt }π Rep MovSW { Copy WordB to WordC }π JNC @NoByteπ MovSB { Copy last Byte }π@NoByte:π LDS SI, WordA { DS:SI contains WordA's address }π Inc SI { SI points to first Char of WordA }π Mov DH, DL { Use DH as a loop counter }π LEA BX, WordC { Load offset of WordC in BX }π Inc BX { Skip length Byte }π { For each letter in WordA, search it in WordB ; if found, mark it asπ 'used' in WordB, then proceed With next.π If a letter is not found, Words are not anagrams ; if all areπ found, Words are anagrams. }π{ Registers usage :π AL : scratch For SCASπ AH : unusedπ BX : offset part of WordC's addressπ CX : will be used as a counter For SCASπ DL : contains length of Strings ; 'll be used to reset CXπ DH : loop counter ; initially =DLπ ES : segment part of WordC's addressπ DI : scratch For SCASπ DS:SI : Pointer to next Char to process in WordAπ}π@Bcle:π LodSB { Load next Char of WordA in AL }π Mov CL, DL { Load length of String in CX }π Mov DI, BX { Copy offset of WordC to DI }π RepNE ScaSB { Scan WordC For AL 'till found }π JNE @NotAng { Char not found, not anagrams }π Dec DI { Back-up to matching Char }π Mov Byte Ptr ES:[DI], '*' { Mark the Character as 'used' }π Dec DH { Dec loop counter }π Or DH, DH { Done all Chars ? }π JNZ @Bcle { No, loop }ππ { All Chars done, the Words are anagrams }π Mov AL, 1 { Result=True }π Or AL, AL { Set accordingly the ZF }π Jmp @Doneπ@NotAng:π XOr AL, AL { Result=False }π@Done:π Pop DS { Restore DS }πend ;ππFunction ReadWordsFrom(FName : String) : Boolean ;πVar InF : Text ; { Input File }π Buf : Array[1..2048] Of Byte ; { Speed-up Text buffer }π Lig : String ; { Read line }π Wrd : String ; { Word gotten from parsed Lig }π WSt : TWordString ; { Checked version of Wrd }π p : Integer ; { Work }π Cnt : LongInt ; { Line counter }πbeginπ ReadWordsFrom:=False ; { 'till now, at least ! }π WordsList:=New(PWordCollection, Init(20, 20)) ;π Assign(InF, FName) ;π {$i-}π ReSet(InF) ;π {$i+}π If IOResult<>0 Then Exit ;π SetTextBuf(InF, Buf, SizeOf(Buf)) ;π Cnt:=0 ;ππ While Not EOF(InF) Doπ beginπ Inc(Cnt) ;π ReadLn(InF, Lig) ;π While Lig<>'' Doπ beginπ { Let's parse the read line into Words }π p:=Pos(',', Lig) ;π If p=0 Then p:=Length(Lig)+1 ;π Wrd:=Copy(Lig, 1, p-1) ;π { Check of overflowing Word length }π If Length(Wrd)>MaxWordLen Thenπ WriteLn('Word length > ', MaxWordLen, ' : ', Wrd) ;π WSt:=Wrd ;π CleanUp(WSt) ;π If WSt<>'' Then WordsList^.Insert(New(PWord, Init(WSt))) ;π Delete(Lig, 1, p) ;π end ;π end ;π {$i-}π Close(InF) ;π {$i+}π If IOResult<>0 Then ;π ReadWordsFrom:=True ;ππ WriteLn(Cnt, ' lines, ', WordsList^.Count, ' Words found.') ;πend ;ππProcedure CheckAnagrams(i : Integer) ;π{ This Procedure builds, if necessary (i.e. not already done), the anagramsπ list For Word #i of the list. }πVar Org : PWord ; { Original Word (1st of list) }π j : Integer ; { Work }π Last : PWord ; { Last anagram found }πbeginπ Org:=WordsList^.Items^[i] ;π If Org^.FirstAng<>Nil Thenπ beginπ { This Word is already known to be the anagram of at least anotherπ one ; don't re-do the job. }π { _or_ this Word is known to have no anagrams in the list }π Exit ;π end ;ππ { Search anagrams }π Last:=Org ;π Org^.FirstAng:=Org ; { This Word is the first of it's }π { own anagrams list ; normal, no ? }π For j:=Succ(i) To Pred(WordsList^.Count) Doπ { Don't search the begining of the list, of course ! }π beginπ { Let's skip anagram checking if lengths are <> }π If Org^.It[0]=PWord(WordsList^.Items^[j])^.It[0] Thenπ If AreAnagrams(Org^.It, PWord(WordsList^.Items^[j])^.It) Thenπ beginπ { Build chained list of anagrams }π Last^.NextAng:=WordsList^.Items^[j] ;π Last:=WordsList^.Items^[j] ;π Last^.FirstAng:=Org ;π end ;π end ;π Last^.NextAng:=Nil ; { Unusefull, but keep carefull }πend ;ππProcedure ScanForAnagrams ;π{ This Procedure scans the list of Words For anagrams, and do the outputingπ to the 'ANAGRAM.RES' File. }ππVar i : Integer ; { Work }π Tmp : PWord ; { Temporary Word }π Out : Text ; { Output File }π Comma : Boolean ; { Helps dealing With commas }π Current : PWord ; { Currently handled Word }πbeginπ Assign(Out, OutFileName) ;π ReWrite(Out) ;ππ With WordsList^ Doπ For i:=0 To Pred(Count) Doπ beginπ Current:=Items^[i] ;π CheckAnagrams(i) ;π { We're now gonna scan the chained list of known anagrams forπ this Word. }π If (Current^.NextAng<>Nil) Or (Current^.FirstAng<>Current) Thenπ { This Word has at least an anagram other than itself }π beginπ Write(Out, PadStr(Current^.It, 12)) ;π Inc(CntAnagrams) ;π Comma:=False ;π Tmp:=Current^.FirstAng ;π While Tmp<>Nil Doπ beginπ If Tmp<>Current Then { Don't reWrite it... }π beginπ If Comma Then Write(Out, ', ') ;π Comma:=True ;π Write(Out, Tmp^.It) ;π Inc(CntAnagrams) ;π end ;π Tmp:=Tmp^.NextAng ;π end ;π WriteLn(Out) ;π end ;π end ;ππ Close(Out) ;πend ;ππVar Tmp : LongInt ;ππbeginπ { Check command line parameter }ππ If ParamCount<>1 Thenπ beginπ WriteLn('Anagram. Raphaël Vanney, 01/93 - Anagram''s contest entry.');π WriteLn ;π WriteLn('Anagram <input_File>') ;π WriteLn ;π WriteLn('Please specify input File name.') ;π Halt(1) ;π end ;ππ OrgMem:=MemAvail ;ππ { Read Words list from input File }ππ If Not ReadWordsFrom(ParamStr(1)) Thenπ beginπ WriteLn('Error reading Words from input File.') ;π Halt(1) ;π end ;ππ { Display statistics stuff }ππ WriteLn('Reading and sorting done.') ;π UsedMem:=OrgMem-MemAvail ;π WriteLn('Used RAM : ', UsedMem, ' Bytes') ;π Tmp := Trunc(1.0 * MemAvail / (1.0 * UsedMem / WordsList^.Count)) ;π If Tmp > 16383 Thenπ Tmp := 16383 ;π WriteLn('Potential Words manageable : ', Tmp) ;ππ { Scan For anagrams, create output File }ππ ScanForAnagrams ;π WriteLn('Anagrams scanning & output done.') ;π WriteLn(CntAnagrams, ' Words written to ', OutFileName) ;ππ { Clean-up }π Dispose(WordsList, Done) ;πend.π{ππ------------------------------------------------------------------------------ππOkay, this is my entry For the 'anagram contest' !ππThe few things I'd like to point-out about it :ππ. I chosed to use OOP, in contrast to seeking speed. I wouldn't say myπ Program is Really slow (7.25 secs on my 386-33), but speed was not myπ first concern.π. It fully Uses one of the interresting points of OOP in TP, i.e.π reusability, through inheritance,π. When a Word (A) has been found to be an anagram of another (B), theπ Program never searches again For the anagrams of (A) ; thisπ highly reduces computing time... but I believe anybody does the same.π. I also quite like the assembly langage Function 'AreAnagrams'.ππ------------------------------------------------------------------------------ππThe Words list is stored in memory in the following maner :π. A collection (say, a list) of the Words,π. Within this list, anagrams are chained as a listπ. Each Word knows the first and the next of its anagramsππ------------------------------------------------------------------------------ππFor the sake of speed, I did something I'm quite ashamed of ; but itπsaves 32% of execution time, so...πThe usual way to access element #i of a TCollection is to call Function Atπwith parameter i (i.e. At(i)) ; there is also another way, which is not Reallyπclean, but which I chosed to use : access it directly through Items^[i].π 4 05-28-9313:57ALL SWAG SUPPORT TEAM BUBBLE1.PAS IMPORT 6 S└Q {π> Does anyone know of a routine or code that would allow For aπ> alphabetical sort?ππDepends on what Type of sorting you want to do- For a very small list, aπsimple BubbleSort will suffice.π}πConstπ max = 50;πVarπ i,j:Integer;π a : Array[1..max] of String;π temp : String;πbeginπ For i := 1 to 50 doπ For j := 1 to 50 doπ if a[i] < a[j] thenπ beginπ temp := a[i];π a[i] := a[j];π a[j] := temp;π end; { if }πend.ππ{πIf it's a bigger list than, say 100 or so elements, or it needs to beπsorted often, you'll probably need a better algorithm, like a shell sortπor a quicksort.π}ππ 5 05-28-9313:57ALL SWAG SUPPORT TEAM BUBBLE2.PAS IMPORT 8 S═M {π> Does anyone know of a routine or code that would allow forπ> a alphbetical sort in pascal? If so could you mail orπ> Write it in this base? Thanks!ππI know of a couple but this is the best and fastest one that I know ofππBubble Sortπ}ππTypeπ StArray = Array [1..10] of String;ππProcedure bubble_sort(Var names : StArray);πVarπ i,π last,π latest : Integer;π temp : String;π exchanged : Boolean;πbeginπ last := max_names - 1;π Repeatπ i := 1;π exchanged := False;π latest := last;π Repeatπ if names[i] > names[i+1] thenπ beginπ temp := names[i];π names[i] := names[i+1];π names[i+1] := temp;π exchanged := True;π latest := i;π end;π inc(i);π Until not (i <= last);π last := latest;π Until not ((last >= 2) and exchanged);πend;π 6 05-28-9313:57ALL SWAG SUPPORT TEAM COMB1.PAS IMPORT 11 SO{ {π>Has anyone successfully converted the Combsort algorithm (I think it wasπ>published in DDJ or Byte about two years ago) from C to Pascal? I'veπ>lost the original C source For this, but if anyone has any info, I wouldπ>appreciate it.π}ππProgram TestCombSort; { Byte magazine, April '91 page 315ff }πConstπ Size = 25;πTypeπ SortType = Integer;πVarπ A: Array [1..size] of SortType;π i: Word;ππProcedure CombSort (Var Ain);πVarπ A: Array [1..Size] of SortType Absolute Ain;π Switch: Boolean;π i, j, Gap: Word;π Hold: SortType;πbeginπ Gap := Size;π Repeatπ Gap := Trunc (Gap / 1.3);π if Gap < 1 thenπ Gap := 1;π Switch := False;π For i := 1 to Size - Gap doπ beginπ j := i + Gap;π if A [i] > A [j] then { swap }π beginπ Hold := A [i];π A [i] := A [j];π A [j] := Hold;π Switch := True;;π end;π end;π Until (Gap = 1) and not Switch;πend;ππbeginπ Randomize;π For i := 1 to Size doπ A [i] := Random (32767);π WriteLn;π WriteLn ('Unsorted:');π For i := 1 to Size doπ Write (A [i]:8);π WriteLn;π CombSort (A);π WriteLn ('Sorted:');π For i := 1 to Size doπ Write (A [i]:8);π WriteLn;πend.π 7 05-28-9313:57ALL SWAG SUPPORT TEAM COUNT1.PAS IMPORT 16 Séâ {π ...Well, as Greg Vigneault reminded me, there is a much fasterπ method of sorting this sort of data called a "Count" sort. Iπ often overlook this method, as it doesn't appear to be a sortπ at all at first glance:π}πProgram Count_Sort_Demo;ππConstπ co_MaxItem = 200;ππTypeπ byar_MaxItem = Array[1..co_MaxItem] of Byte;π byar_256 = Array[0..255] of Byte;ππVarπ by_Index : Byte;π wo_Index : Word;π DataBuffer : byar_MaxItem;π SortTable : byar_256;ππbeginπ (* Initialize the pseudo-random number generator. *)π randomize;ππ (* Clear the CountSort table. *)π fillChar(SortTable, sizeof(SortTable), 0);ππ (* Create random Byte data. *)π For wo_Index := 1 to co_MaxItem doπ DataBuffer[wo_Index] := random(256);ππ (* Display random data. *)π Writeln;π Writeln('RANDOM Byte DATA');π For wo_Index := 1 to co_MaxItem doπ Write(DataBuffer[wo_Index]:4);ππ (* CountSort the random data. *)π For wo_Index := 1 to co_MaxItem doπ inc(SortTable[DataBuffer[wo_Index]]);ππ (* Display the CountSorted data. *)π Writeln;π Writeln('COUNTSORTED Byte DATA');π For by_Index := 0 to 255 doπ if (SortTable[by_Index] > 0) thenπ For wo_Index := 1 to SortTable[by_Index] doπ Write(by_Index:4)πend.π{π ...This Type of sort is EXTEMELY fast, even when compared toπ QuickSort, as there is so little data manipulation being done.ππ>BTW, why are there so many different sorting methods?π>Quick, bubble, Radix.. etc, etcππ ...Because, Not all data is created equally.π (ie: Some Types of sorts perform well on data that is veryπ random, While other Types of sorts perform well on dataπ that is "semi-sorted" or "almost sorted".)ππ} 8 05-28-9313:57ALL SWAG SUPPORT TEAM COUNT2.PAS IMPORT 34 S÷\ {π>I'm in need of a FAST way of finding the largest and the smallestπ>30 numbers out of about 1000 different numbers.π> ...Assuming that the 1000 numbers are in random-order, I imagineπ> that the simplest (perhaps fastest too) method would be to:π> 1- Read the numbers in an Array.π> 2- QuickSort the Array.π> 3- First 30 and last 30 of Array are the numbers you want.π> ...Here's a QuickSort demo Program that should help you With theπ> sort: ...ππ Stop the presses, stop the presses!ππ Remember the recent Integer sort contest, on the Intelec Programmingπ conference? The fastest method was a "counting" sort technique, whichπ used the Integers (to be sorted) as indexes of an Array.ππ You asked John Kuhn how it worked, as his example code was in messyπ C. I sent you an explanation, along With example TP source. Aroundπ that time my link to Intelec was intermittently broken; I didn'tπ hear back from you - so you may not have received my message (datedπ Jan.02.1993). I hope you won't mind if I re-post it here and now...ππ In a message With John Kuhn...π> Simply toggle the sign bit of the values beFore sorting. Everythingπ> falls into place appropriately from there.π> ...OK, but how about toggling them back to their originalπ> state AFTER sorting? (I want to maintain negative numbers)π> How can you tell which data elements are negative numbers???ππ Hi Guy,ππ if you've got all of this under your belt, then please disregardπ the following explanation ...ππ By toggling the high bit, the Integers are changed in a way that,π conveniently, allows sorting by magnitude: from the "most negative"π to "most positive," left to right, using an Array With unsignedπ indexes numbering 0...FFFFh. The Array size represents the numberπ of all possible (16-bit) Integers... -32768 to 32767.ππ The "Count Sort" involves taking an Integer, toggling its high bitπ (whether the Integer is originally positive or negative), thenπ using this tweaked value as an index into the Array. The tweakedπ value is used only as an Array index (it becomes an unsignedπ index somewhere within 0..FFFFh, inclusive).ππ The Array elements, which are initialized to zero, are simply theπ counts of the _occurrences_ of each Integer. The original Integers,π With proper sign, are _derived_ from the indexes which point toπ non-zero elements (after the "sort")... ie. an original Integer isπ derived by toggling the high bit of a non-zero element's index.ππ Array elements of zero indicate that no Integer of the correspondingπ (derived) value was encountered, and can be ignored. if any elementπ is non-zero, its index is used to derive the original Integer. ifπ an Array element is greater than one (1), then the correspondingπ Integer occurred more than once.ππ A picture is worth 1000 Words: The following simplified exampleπ sorts some negative Integers. The entire Count Sort is done byπ a Single For-do-inC() loop - hence its speed. The xors do theπ required high-bit toggling ...π}πππProgram DemoCountSort; { Turbo Pascal Count Sort. G.Vigneault }ππ{ some negative Integers to sort ... }πConstπ SomeNegs : Array [0..20] of Integer =π (-2,-18,-18,-20000,-100,-10,-8,-11,-5,π -1300,-17,-1,-16000,-4,-12,-15,-19,-1,π -31234,-6,-7000 );ππ{ pick an Array to acComplish Count Sort ... }πVarπ NegNumArray : Array [$0000..$7FFF] of Byte;π{ PosNumArray : Array [$8000..$FFFF] of Byte; }π{ AllNumArray : Array [$0000..$FFFF] of Byte; use heap }π Index : Word;π IntCount : Byte;ππbeginπ { Initialize }π FillChar( NegNumArray, Sizeof(NegNumArray), 0 );ππ { Count Sort (the inC does this) ... }ππ For Index := 0 to 20 doπ { Just 21 negative Integers to sort }π inC( NegNumArray[ Word(SomeNegs[Index] xor $8000) ]);ππ { then display the sorted Integers ... }π For Index := 0 to $7FFF doπ { Check each Array element }π For IntCount:= 1 to NegNumArray[Index] doπ { For multiples }π WriteLn( Integer(Index xor $8000) ); { derive value }ππend { DemoCountSort }.π 9 05-28-9313:57ALL PEDRO DUARTE Elevator Sort IMPORT 15 SMb {π> Thanks For the code... It worked great! BTW, why are there so manyπ> different sorting methods? Quick, bubble, Radix.. etc, etcππYes, there are lots of sorting algorithms out there! I also found this outπthe hard way! :-) A couple of years ago, I only knew the so-called "bubble"πsort, and decided to create my own sorting algorithm. It would have to beπfaster than bubble, yet remaining small, simple, and not memory hungry.πand I did it, but only to find out a few weeks later that there were muchπbetter sorts than the one I created... But it sure was great fun beatingπbubble! (which is brain-dead anyway! ;-)ππSo here it is, my two cents to the history of sorting algorithms, theπamazing, blazingly fast (*)... ELEVAtoR SorT!... Why ELEVAtoR??, you ask inπunison! Because it keeps going up & down! :-)π}ππProgram mysort;ππUses Crt;ππConstπ max = 1000;ππTypeπ list = Array[1..max] of Word;ππVarπ data : list;π dummy : Word;πππProcedure elevatorsort(Var a: list; hi: Word);ππVarπ lo,π peak,π temp,π temp2 : Word;ππbeginπ peak := 1;π lo := 1;π Repeatπ temp := a[lo];π temp2 := a[lo + 1];π if temp > temp2 thenπ beginπ a[lo] := temp2;π a[lo + 1] := temp;π if lo <> 1 then dec(lo);π endπ elseπ beginπ inc(peak);π lo:=peak;π end;π Until lo = hi;πend;πππbeginπ ClrScr;π Writeln('Generating ', max ,' random numbers...');π randomize;π For dummy:=1 to max do data[dummy]:=random(65535);π Writeln('Sorting random numbers...');π elevatorsort(data,max);π For dummy:=1 to max do Write(data[dummy]:5,' ');πend.ππ{π(*) it's speed lies somewhere between "BUBBLE" and "inSERT"; it's muchπfaster than "BUBBLE", and a little slower than "inSERT"... :-)π}π 10 05-28-9313:57ALL SWAG SUPPORT TEAM ELEVATR2.PAS IMPORT 11 Såc {π>Why can't Borland come out With a Universal sort since they made theπ>Program.. <G>ππI guess there's no such thing as a "universal" sort... There are a few veryπgood sorting algorithms, and depending on some factors, you just have toπchoose the one that best fits your needs!ππHere's an update to my ELEVAtoR sort, this one's even faster!π}ππProgram mysort;ππUses Crt;ππConstπ max = 1000;ππTypeπ list = Array[1..max] of Word;ππVarπ data : list;π dummy : Word;πππProcedure elevatorsort(Var a: list; hi: Word);ππVarπ dummy,π low,π peak,π temp,π temp2 : Word;ππbeginπ peak := 1;π low := 1;π temp2 := a[low + 1];π Repeatπ temp := a[low];π if temp > temp2 thenπ beginπ a[low] := temp2;π a[low + 1] := temp;π if low <> 1 then dec(low);π endπ elseπ beginπ inc(peak);π low:=peak;π if low <> hi then temp2:=a[low + 1];π end;π Until low = hi;πend;ππbeginπ ClrScr;π Writeln('Generating ', max ,' random numbers...');π randomize;π For dummy:=1 to max do data[dummy]:=random(65535);π Writeln('Sorting random numbers...');π elevatorsort(data,max);π For dummy:=1 to max do Write(data[dummy]:5,' ');πend.π 11 05-28-9313:57ALL SWAG SUPPORT TEAM IMROVSRT.PAS IMPORT 20 S╛= {πMARK OUELLETππ> I code these things this way:π>π> for I := 1 to MAX-1 doπ> for J := I+1 to MAX doπ> if A[I] < A[J] thenπ> beginπ> ( swap code )π> endππ this can be improved even more. By limiting the MAX value on eachπsuccessive loop by keeping track of the highest swaped pair.ππ If on a particular loop, no swap is performed from element MAX-10πonto the end. Then the next loop does not need to go anyhigher thanπMAX-11. Remember you are moving the highest value up, if no swap isπperformed from MAX-10 on, it means all values above MAX-11 are in orderπand all values below MAX-10 are smaller than MAX-10.π}ππ{$X+}πprogram MKOSort;ππUSESπ Crt;ππConstπ MAX = 1000;ππvarπ A : Array[1..MAX] of word;π Loops : word;ππprocedure Swap(Var A1, A2 : word);πvarπ Temp : word;πbeginπ Temp := A1;π A1 := A2;π A2 := Temp;πend;ππprocedure working;πconstπ cursor : array[0..3] of char = '\|/-';π CurrentCursor : byte = 1;π Update : word = 0;πbeginπ update := (update + 1) mod 2500;π if update = 0 thenπ beginπ DirectVideo := False;π write(Cursor[CurrentCursor], #13);π CurrentCursor := ((CurrentCursor + 1) mod 4);π DirectVideo := true;π end;πend;ππprocedure Bubble;πvarπ Highest,π Limit, I : word;π NotSwaped : boolean;πbeginπ Limit := MAX;π Loops := 0;π repeatπ I := 1;π Highest := 2;π NotSwaped := true;π repeatπ working;π if A[I] > A[I + 1] thenπ beginπ Highest := I;π NotSwaped := False;π Swap(A[I], A[I + 1]);π end;π Inc(I);π until (I = Limit);π Limit := Highest;π Inc(Loops);π until (NotSwaped) or (Limit <= 2);πend;ππprocedure InitArray;πvarπ I, J : word;π Temp : word;πbeginπ randomize;π for I := 1 to MAX doπ A[I] := I;π for I := MAX - 1 downto 1 doπ beginπ J := random(I) + 1;π Swap(A[I + 1], A[J]);π end;πend;ππprocedure Pause;πbeginπ writeln;π writeln('Press any key to continue...');π while keypressed doπ readkey;π while not keypressed do;π readkey;πend;ππprocedure PrintOut;πvarπ I : word;πbeginπ ClrScr;π For I := 1 to MAX doπ beginπ if WhereY >= 22 thenπ beginπ Pause;π ClrScr;π end;π if (WhereX >= 70) thenπ Writeln(A[I] : 5)π elseπ Write(A[I] : 5);π end;π writeln;π Pause;πend;ππbeginπ ClrScr;π InitArray;π PrintOut;π Bubble;π PrintOut;π writeln;π writeln('Took ', Loops, ' Loops to complete');πend.π 12 05-28-9313:57ALL SWAG SUPPORT TEAM MODHEAP.PAS IMPORT 39 Svº {πOk, here is your "fastest sort routine." I spent a couple hours just tweakingπand testing to make sure that it was performing 100%.ππAdding $G+ only yielded a very slight speed increase but a noticeable one. (Theπspeed results below are based on $G-.) Using anything other than Integer forπVariables caused a slight degredation in performance. I would guess thatπInteger arithmetic is where Borland focused its optimizations on. Word andπLongInt all caused performance degredation.ππAND, it used to be that previous to v6 or v5.5 that multiplication was a bottleπneck too, as in J := I * 3; The faster method was to say J := I+I+I; sinceπaddition is faster than multiplication. I didn't see any appreciable differenceπwith respect to multiplication over addition here.ππThe following algorithm is a modified Fibonacci Heap sort With the addition ofπa mid-sort bounce technique. It runs almost twice the speed of the Quick Sortπalgorithm as posted in my last message.ππIt Uses considerably less stack then Quick Sort since it is non-recursive. And,πfor those of you who hate GOTO's, there's three in this code. Any other way Iπcould think of would increase data and reduce performance. But you're certainlyπwelcome to jump in and knock 'em outa there if you can!ππHere are the speed results as tested on 386-40mhz:ππ 500 Elements - (Less than 1/10 second)π 1000 Elements - 0.1 Secondsπ 1500 Elements - 0.2 Secondsπ 2000 Elements - 0.3 Secondsπ 5000 Elements - 1.0 Secondsπ 7500 Elements - 1.7 Secondsπ 10000 Elements - 2.3 SecondsππI modified the skeleton Program slightly to increase the number of 10 CharacterπStrings to 10,000 so that I could test that far.ππHere is the source code For the algorithm. Just "Plug" it into the skeletonπProgram I posted a day or so ago.ππ{------------------------------------------------------------------------}πProcedure ModHeapSort( Total : Integer );πVarπ I,J,K,L : Integer;π X, Temp : Pointer;π M,M1,M2 : Integer;ππ Label JumpOut;π Label Terminate;π Label SmallSort;ππbeginπ if Total <= 4 Thenπ Goto SmallSort; { Too small For Split sorting }ππ M := Pred(Total) div 3;π M1 := ( M * 3 ) + 2;ππ if M1 <= Total Thenπ beginπ if M1 < Total Thenπ if SortArray[M1]^ < SortArray[Total]^ Thenπ M2 := Totalπ ELSEπ M2 := M1π ELSEπ M2 := M1;ππ if SortArray[1]^ < SortArray[M2]^ Thenπ begin { Swap first element to M2 }π Temp := SortArray[1];π SortArray[1] := SortArray[M2];π SortArray[M2] := Temp;π end;ππ end; {IF M1 <= Total}ππ For L := M DownTo 1 DOπ beginπ X := SortArray[L];π I := L;π J := I * 3;ππ Repeatππ K := Pred(J);ππ if SortArray[K]^ < SortArray[J]^ Thenπ K := J;π if SortArray[K]^ < SortArray[Succ(J)]^ Thenπ K := Succ(J);ππ SortArray[I] := SortArray[K];π I := K;π J := I * 3;ππ Until J > M1;ππ J := Succ(I) div 3;ππ Repeatππ if SortArray[J]^ >= SmallArrPtr(X)^ Thenπ Goto JumpOut;ππ SortArray[I] := SortArray[J];π I := J;π J := Succ(J) div 3;ππ Until J < L;ππ JumpOut:π SortArray[I] := X;ππ end;ππ For L := M1 To Total DOπ beginπ X := SortArray[L];π I := L;π J := Succ(I) div 3;ππ if SortArray[J]^ < SmallArrPtr(X)^ Thenπ beginππ Repeatπ SortArray[I] := SortArray[J];π I := J;π J := Succ(J) div 3;π Until SortArray[J]^ >= SmallArrPtr(X)^;ππ SortArray[I] := X;ππ end; {IF}π end; {For}ππ L := Total;ππ While L > 4 DOπ beginπ X := SortArray[L];π SortArray[L] := SortArray[1];π Dec(L,1);π I := 1;π J := 3;ππ Repeatπ K := Pred(J);ππ if SortArray[K]^ < SortArray[J]^ Thenπ K := J;π if SortArray[K]^ < SortArray[Succ(J)]^ Thenπ K := Succ(J);ππ SortArray[I] := SortArray[K];π I := K;π J := I * 3;π Until J >= L;ππ Dec(J,1);ππ if J <= L Thenπ beginπ if J < L Thenπ if SortArray[J]^ < SortArray[L]^ Thenπ J := L;π SortArray[I] := SortArray[J];π I := J;π end; {IF}ππ J := Succ(I) div 3;ππ if SortArray[J]^ < SmallArrPtr(X)^ Thenπ Repeatπ SortArray[I] := SortArray[J];π I := J;π J := Succ(J) div 3;π Until SortArray[J]^ >= SmallArrPtr(X)^;ππ SortArray[I] := X;π end;ππ { Process last four remaining elements, or less than 4 to sort }π { Use "Insertion sort" method For best linear time performance }ππ SmallSort :π if Total <= 4 Thenπ L := Totalπ ELSEπ L := 4;ππ For I := 2 To L DOπ beginπ X := SortArray[I];π For J := Pred(I) DownTo 1 DOπ if SortArray[J]^ > SmallArrPtr(X)^ Thenπ SortArray[Succ(J)] := SortArray[J]π ELSEπ Goto Terminate;π J := 0;ππ Terminate : SortArray[Succ(J)] := X;ππ end; {For I}πend;π 13 05-28-9313:57ALL SWAG SUPPORT TEAM OOP-SORT.PAS IMPORT 10 Su {πWL> Say, would anyone know how-to sort a Record With 5 thingπ WL> in it one of which is "NAME"...I want to sort each Recordπ WL> in the Array by name and can't figure it out....my Arrayπ WL> name is LabelS and my Record name is SofT....so any helpπ WL> would greatly be appreciated...thanksππThe easiest way is to make it an Object, and put it in a TSortedCollection.πFor example:π}ππ Typeπ PMyrec = ^TMyrec;π TMyrec = Object(tObject)π name : String;π other : Integer;π end;ππ TSortedRecs = Object(TSortedCollection)π Function Compare(Key1,key2:Pointer):Integer; Virtual;π end;ππ Function TSortedRecs.Compare;π Varπ p1 : PMyrec Absolute Key1;π p2 : PMyrec Absolute Key2;π beginπ if p1^.name < p2^.name thenπ Compare := -1π else if p1^.name = p2^.name thenπ Compare := 0π elseπ Compare := 1;π end;ππVarπ rec : PMyrec;π coll: TSortedRecs; beginπ coll.init(100,10); { Init to 100 Records, grow by 10s }ππ While More_Records doπ beginπ new(rec,init);π rec^.name := Get_Name;π rec^.other:= Get_Other;π coll.insert(rec);π end;π 14 05-28-9313:57ALL REYNIR STEFANSSON Pointer Sort IMPORT 28 S8φ {πREYNIR STEFANSSONππSome time ago I wangled myself into a beta testing team For a floppyπdisk catalogger called FlopiCat. This is a rather BASIC (in more than oneπway) Program, but works well enough.ππThe built-in sorting routine was a bit quacked, so I wrote my ownπexternal sorter, which is both more versatile and faster (by far) than theπinternal one.ππ Here it is, in Case someone can use the idea (and code):π}ππProgram FlopiSrt; { Sorts FlopiCat.Dat. }ππConstπ Maximum = 6000; { I don't need that many meself... }π FName : String[12] = 'Flopicat.Dat';ππTypeπ fEntry = Recordπ n : Array[1..4] of Char;π i : Array[1..35] of Char;π d : Array[1..39] of Char;π end;ππ En1 = Array[1..78] of Char;π En2 = Recordπ n : Array[1..4] of Char;π f : Array[1..9] of Char;π e : Array[1..3] of Char;π z : Array[1..8] of Char;π t : Array[1..15] of Char;π d : Array[1..39] of Char;π end;ππ En3 = Recordπ f, d : Array[1..39] of Char;π end;ππ pEntry = ^fEntry;ππVarπ Entry : Array [1..Maximum] of pEntry;π fc : File of fEntry;π Rev : Boolean;π LoMem : Pointer;π i,π NumOfEntries : Integer;π nfd : Char;π s : String;ππFunction ToSwap(i, j : Integer) : Boolean;πVarπ Swop : Boolean;πbeginπ Swop := False;π Case nfd OFπ { Sorting by disk number: }π 'N' : if Entry[i]^.n > Entry[j]^.n thenπ Swop := True;π { Sorting by File information: }π 'I' : if Entry[i]^.i > Entry[j]^.i thenπ Swop := True;π { Sorting by description: }π 'D' : if Entry[i]^.d > Entry[j]^.d thenπ Swop := True;π { Sorting by all the String: }π 'A' : if En1(Entry[i]^) > En1(Entry[j]^) thenπ Swop := True;π { Sorting by File name only: }π 'F' : if En2(Entry[i]^).f > En2(Entry[j]^).f thenπ Swop := True;π { Sorting by File extension only: }π 'E' : if En2(Entry[i]^).e > En2(Entry[j]^).e thenπ Swop := True;π { Sorting by File size: }π 'Z' : if En2(Entry[i]^).z > En2(Entry[j]^).z thenπ Swop := True;π { Sorting by date/time stamp: }π 'T' : if En2(Entry[i]^).t > En2(Entry[j]^).t thenπ Swop := True;π { Sorting by disk number/File info block: }π 'B' : if En3(Entry[i]^).f > En3(Entry[j]^).f thenπ Swop := True;π end;π ToSwap := Swop xor Rev;πend;ππ{ if I remember correctly, I settled on using shaker/shuttle sort. }πProcedure SortIt;πVarπ i, j,π pb, pf,π pp, pt : Integer;π t : pEntry;ππ Procedure SwapIt(i, j : Integer);π beginπ t := Entry[i];π Entry[i] := Entry[j];π Entry[j] := t;π end;ππbeginπ Write('0 entries processed.');π i := 0;π pt := 2;π pb := NumOfEntries;π pf := 0;π Repeatπ pp := pt;π Repeatπ if ToSwap(pp - 1, pp) thenπ beginπ SwapIt(pp - 1, pp);π pf := pp;π end;π Inc(pp);π Until pp > pb;ππ pb := pf - 1;π j := i;π i := NumOfEntries - (pb - pt + 2);π if (i MOD 10) < (j MOD 10) thenπ Write(#13, i);π if pb < pt thenπ Exit;π pp := pb;ππ Repeatπ if ToSwap(pp - 1, pp) thenπ beginπ SwapIt(pp - 1, pp);π pf := pp;π end;π Dec(pp);π Until pp < pt;ππ pt := pf + 1;π j := i;π i := NumOfEntries - (pb - pt + 2);π if (i MOD 10) < (j MOD 10) thenπ Write(#13, i);π Until pb < pt;πend;ππ 15 05-28-9313:57ALL SWAG SUPPORT TEAM QUICK1.PAS IMPORT 15 Sσú Unit Qsort;ππ{ππCopyright 1990 Trevor J CarlsenπAll rights reserved.ππAuthor: Trevor J Carlsenπ PO Box 568π Port Hedland WA 6721π πA general purpose sorting Unit.πππ}ππInterfaceππTypeπ updown = (ascending,descending);π str255 = String;π dataType = str255; { the Type of data to be sorted }π dataptr = ^dataType;π ptrArray = Array[1..10000] of dataptr;π Arrayptr = ^ptrArray;π πConst π maxsize : Word = 10000;π SortType : updown = ascending;π πProcedure QuickSort(Var da; left,right : Word);ππ{============================================================================}πImplementationπ πProcedure swap(Var a,b : dataptr); { Swap the Pointers }π Var t : dataptr;π beginπ t := a;π a := b;π b := t;π end;π π πProcedure QuickSort(Var da; left,right : Word);π Varπ d : ptrArray Absolute da;π pivot : dataType;π lower,π upper,π middle : Word;ππ beginπ lower := left;π upper := right;π middle:= (left + right) div 2;π pivot := d[middle]^;π Repeatπ Case SortType ofπ ascending : beginπ While d[lower]^ < pivot do inc(lower);π While pivot < d[upper]^ do dec(upper);π end;π descending: beginπ While d[lower]^ > pivot do inc(lower);π While pivot > d[upper]^ do dec(upper);π end;π end; { Case } π if lower <= upper then beginπ { swap the Pointers not the data }π swap(d[lower],d[upper]);π inc(lower);π dec(upper);π end;π Until lower > upper;π if left < upper then QuickSort(d,left,upper);π if lower < right then QuickSort(d,lower,right);π end; { QuickSort }ππend.πππ 16 05-28-9313:57ALL SWAG SUPPORT TEAM QUICK2.PAS IMPORT 16 Sâ {...This is as generic a QuickSort as I currently use:π}π{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,R-,S-,T-,V-}π{$M 60000,0,0}ππProgram QuickSortDemo;πUsesπ Crt;ππConstπ coMaxItem = 30000;ππTypeπ Item = Word;π arItem = Array[1..coMaxItem] of Item;ππ (***** QuickSort routine. *)π (* *)πProcedure QuickSort({update} Var arData : arItem;π {input } woLeft,π woRight : Word);πVarπ Pivot,π TempItem : Item;π woIndex1,π woIndex2 : Word;πbeginπ woIndex1 := woLeft;π woIndex2 := woRight;π Pivot := arData[(woLeft + woRight) div 2];π Repeatπ While (arData[woIndex1] < Pivot) doπ inc(woIndex1);π While (Pivot < arData[woIndex2]) doπ dec(woIndex2);π if (woIndex1 <= woIndex2) thenπ beginπ TempItem := arData[woIndex1];π arData[woIndex1] := arData[woIndex2];π arData[woIndex2] := TempItem;π inc(woIndex1);π dec(woIndex2)π endπ Until (woIndex1 > woIndex2);π if (woLeft < woIndex2) thenπ QuickSort(arData, woLeft, woIndex2);π if (woIndex1 < woRight) thenπ QuickSort(arData, woIndex1, woRight)πend; (* QuickSort. *)ππVarπ woIndex : Word;π Buffer : arItem;ππbeginπ Write('Creating ', coMaxItem, ' random numbers... ');π For woIndex := 1 to coMaxItem doπ Buffer[woIndex] := random(65535);π Writeln('Finished!');π Write('Sorting ', coMaxItem, ' random numbers... ');π QuickSort(Buffer, 1, coMaxItem);π Writeln('Finished!');π Writeln;π Writeln('Press the <ENTER> key to display all ', coMaxItem,π ' sorted numbers...');π readln;π For woIndex := 1 to coMaxItem doπ Write(Buffer[woIndex]:8)πend.π 17 05-28-9313:57ALL TEK CHAN Quick Sort IMPORT 13 S╨O { File that will teach me how to quick sort? I know how quick sort worksπ but I don't know why my Program doesn't sort properaly. Sometimes it goesπ through one cycle of sort and sometimes it goes through two cycles of sortπ but it never sorts it Completely! Tek ChanππHere is some generic source code, change it to suit your needs/Types:π}ππProcedure Split(Var Info: ArrayType; First: Integer; Last: Integer; VarπSplitPt1: Integer; Var SplitPt2: Integer);ππVar SplitVal, Temp: ArrayElementType;ππbeginπ SplitVal:=Info[(First+Last) div 2];π Repeatπ While Info[First] < SplitVal doπ First:=First+1;π While Info[Last] > SplitVal doπ Last:=Last-1;π if First <= Last thenπ beginπ Temp:=Info[First];π Info[First]:=Info[Last];π Info[Last]:=Temp;π First:=First+1;π Last:=Last-1;π endπ Until First > Last;π SplitPt1:=First;π SplitPt2:=Last;πend;ππProcedure QuickSort(Var Info: ArrayType; First:Integer; Last: Integer);ππVar SplitPt1, SplitPt2: Integer;ππbeginπ if First < Last thenπ beginπ Split(Info, First, Last, SplitPt1, SplitPt2);π if SplitPt1 < Lastπ then QuickSort(Info, SplitPt1, Last);π if First < SplitPt2π then QuickSort(Info, First, SplitPt2);π endπend;ππ{πThis is a -very- fast sort, much faster than any other I have. Does aπnon-recursive version exist? Are there any faster sorts? Brianπ} 18 05-28-9313:57ALL SWAG SUPPORT TEAM QUICK4.PAS IMPORT 17 S⌠v Unit qsort;ππInterfaceππProcedure quicksort(Var s; left,right : Word);ππImplementationππProcedure quicksort(Var s; left,right : Word; SortType: sType);π { On the first call left should always be = to min and right = to max }π Varπ data : DataArr Absolute s;π pivotStr,π tempStr : String;π pivotLong,π tempLong : LongIntπ lower,π upper,π middle : Word;ππ Procedure swap(Var a,b);π Var x : DirRec Absolute a;π y : DirRec Absolute b;π t : DirRec;π beginπ t := x;π x := y;π y := t;π end;ππ beginπ lower := left;π upper := right;π middle:= (left + right) div 2;π Case SortType ofπ _name: pivotStr := data[middle].name;π _ext : pivotStr := data[middle].ext;π _size: pivotLong := data[middle].Lsize;π _date: pivotLong := data[middle].Ldate;π end; { Case SortType }π Repeatπ Case SortType ofπ _name: beginπ While data[lower].name < pivotStr do inc(lower);π While pivotStr < data[upper].name do dec(upper);π end;π _ext : beginπ While data[lower].ext < pivotStr do inc(lower);π While pivotStr < data[upper].ext do dec(upper);π end;π _size: beginπ While data[lower].Lsize < pivotLong do inc(lower);π While pivotLong < data[upper].Lsize do dec(upper);π end;π _date: beginπ While data[lower].Ldate < pivotLong do inc(lower);π While pivotLong < data[upper].Ldate do dec(upper);π end;π end; { Case SortType }π if lower <= upper then beginπ swap(data[lower],data[upper]);π inc(lower);π dec(upper);π end;π Until lower > upper;π if left < upper then quicksort(data,left,upper);π if lower < right then quicksort(data,lower,right);π end; { quicksort }ππππππππ 19 05-28-9313:57ALL SWAG SUPPORT TEAM QUICK5.PAS IMPORT 19 SΦ, {π>I'm in need of a FAST way of finding the largest and the smallestπ>30 numbers out of about 1000 different numbers.ππ ...Assuming that the 1000 numbers are in random-order, I imagineπ that the simplest (perhaps fastest too) method would be to:ππ 1- Read the numbers in an Array.ππ 2- QuickSort the Array.ππ 3- First 30 and last 30 of Array are the numbers you want.ππ ...Here's a QuickSort demo Program that should help you With theπ sort:π}ππ{$A+,B-,D-,E-,F-,I-,L-,N-,O-,R-,S+,V-}π{$M 60000,0,0}ππProgram QuickSort_Demo;πUsesπ Crt;ππConstπ co_MaxItem = 30000;ππTypeπ Item = Word;π ar_Item = Array[1..co_MaxItem] of Item;πππ (***** QuickSort routine. *)π (* *)πProcedure QuickSort({update} Var ar_Data : ar_Item;π {input } wo_Left,π wo_Right : Word);πVarπ Pivot,π TempItem : Item;π wo_Index1,π wo_Index2 : Word;πbeginπ wo_Index1 := wo_Left;π wo_Index2 := wo_Right;π Pivot := ar_Data[(wo_Left + wo_Right) div 2];π Repeatπ While (ar_Data[wo_Index1] < Pivot) doπ inc(wo_Index1);π While (Pivot < ar_Data[wo_Index2]) doπ dec(wo_Index2);π if (wo_Index1 <= wo_Index2) thenπ beginπ TempItem := ar_Data[wo_Index1];π ar_Data[wo_Index1] := ar_Data[wo_Index2];π ar_Data[wo_Index2] := TempItem;π inc(wo_Index1);π dec(wo_Index2)π endπ Until (wo_Index1 > wo_Index2);π if (wo_Left < wo_Index2) thenπ QuickSort(ar_Data, wo_Left, wo_Index2);π if (wo_Index1 < wo_Right) thenπ QuickSort(ar_Data, wo_Index1, wo_Right)πend; (* QuickSort. *)ππVarπ wo_Index : Word;π ar_Buffer : ar_Item;ππbeginπ Write('Creating ', co_MaxItem, ' random numbers... ');π For wo_Index := 1 to co_MaxItem doπ ar_Buffer[wo_Index] := random(65535);π Writeln('Finished!');π Write('Sorting ', co_MaxItem, ' random numbers... ');π QuickSort(ar_Buffer, 1, co_MaxItem);π Writeln('Finished!');π Writeln;π Writeln('Press the <ENTER> key to display all ', co_MaxItem,π ' sorted numbers...');π readln;π For wo_Index := 1 to co_MaxItem doπ Write(ar_Buffer[wo_Index]:8)πend.π 20 05-28-9313:57ALL SWAG SUPPORT TEAM RADIX1.PAS IMPORT 34 SÇl {π Here's my solution to your "contest". The first I'm rather proudπ of, it incorporates bAsm to beat your devilshly efficient CASEπ Implementation by a factor of 2x.ππ The second, I am rather disappointed With as it doesn't even comeπ CLOSE to TP's inbuilt STR Function. (The reason, I have found, isπ because TP's implementaion Uses a table based approach that wouldπ be hard to duplicate With Variable radixes. I am working on aπ Variable radix table now)πππ ****************************************************************π Converts String pointed to by S into unsigned Integer V. Noπ range or error checking is performed. Caller is responsible forπ ensuring that Radix is in proper range of 2-36, and that noπ invalid Characters exist in the String.π ****************************************************************π}πTypeπ pChar = ^chr_Array;π chr_Array = Array[0..255] of Char;π Byte_arry = Array[Char] of Byte;ππConstπ sym_tab : Byte_arry = (π 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,1,2,3,4,5,6,7,8,9,π 0,0,0,0,0,0,0,10,11,12,13,14,15,16,17,π 18,19,20,21,22,23,24,25,26,27,28,29,30,π 31,32,33,34,35,0,0,0,0,0,0,10,11,12,13,π 14,15,16,17,18,19,20,21,22,23,24,25,26,π 27,28,29,30,31,32,33,34,35,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,0,0,0,0π );ππProcedure RadixVal(Var V:LongInt; S:PChar;Radix:Byte);πVarπ digit :Byte;π p, p2 :Pointer;π hiwd, lowd :Word;πbeginπ V := 0;π p := @S^[0];π p2 := @V;π Asmπ les bx, p2π push dsπ pop esπ lds si, pπ @loop3:π lea di, [sym_tab]π xor ah, ahπ lodsbπ cmp al, 0π je @quitπ add di, ax { index to Char position in table }π mov al, Byte PTR [di]π mov digit, alπ xor ah, ahπ mov al, Radixπ mov cx, axπ mul Word PTR [bx]π mov lowd, axπ mov hiwd, dxπ mov ax, cxπ mul Word PTR [bx+2] { mutliply high Word With radix }π add hiwd, ax { add result to previous result - assume hi result 0 }π mov ax, lowdπ mov dx, hiwdπ add al, digit { add digit value }π adc ah, 0 { resolve any carry }π mov [bx], ax { store final values }π mov [bx+2], dxπ jmp @loop3π @quit:π end;πend;ππ{π ****************************************************************π Convert unsigned Integer in V to String pointed to by S.π Radix determines the base to use in the conversion. No rangeπ checking is performed, the caller is responsible For ensuringπ the radix is in the proper range (2-36), and that V is positive.π ****************************************************************π}πTypeπ Char_arry = Array[0..35] of Char;ππConstπ symbols :Char_arry = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';ππProcedure RadixStr(V:LongInt; S:PChar; Radix:Byte);πVarπ digit, c :Byte;π ts :String;π p, p2 :Pointer;πbeginπ c := 255;π ts[255] := #0;π p := @V;π p2 := @ts[0];π Asmπ push dsπ lea si, [symbols]π les bx, pπ les di, p2π add di, 255π stdπ xor cx, cxπ mov cl, Radixπ @loop:π SEGES mov ax, Word PTR [bx]π SEGES mov dx, Word PTR [bx+2]π div cxπ SEGES mov Word PTR [bx], axπ SEGES mov Word PTR [bx+2], 0π mov digit, dlπ push siπ xor ah, ahπ mov al, digitπ add si, axπ movsbπ pop siπ dec cπ SEGES cmp Word PTR [bx], 0π je @doneπ SEGES cmp Word PTR [bx+2], 0π je @loopπ @done:π pop dsπ end;π ts[c] := Chr(255-c);π p := @S^[0];π Asmπ push dsπ cldπ lds si, p2π les di, pπ xor bx, bxπ mov bl, cπ add si, bxπ mov cx, 256π sub cl, cπ sbb ch, 0π rep movsbπ pop dsπ end;πend;π 21 05-28-9313:57ALL SWAG SUPPORT TEAM RADIX2.PAS IMPORT 16 S╒^ {>...Assuming that the 1000 numbers are in random-order, I imagineπ> that the simplest (perhaps fastest too) method would be to:π> 1- Read the numbers in an Array.π> 2- QuickSort the Array.π> 3- First 30 and last 30 of Array are the numbers you want.ππ>Stop the presses, stop the presses!ππ <grin>ππ>Remember the recent Integer sort contest, on the Intelecπ>Programming conference?ππ ...Ah, yes... I always tend to Forget about that method.π Yes, a "count" sort would definitely be the fastest methodπ of sorting random numerical data.π ...What I had a few troubles figuring out from that postπ in the Intelec confrence, wasn't the "count sort" method,π but rather the "radix sort" or "digital sort" method,π where specific bits within each data element are usedπ to sort the data.ππ ...Here's the algorithm listed in Robert Sedgewick'sπ "Algorithms" book, published by Addison-Wesley Publishingπ Company, ISBN 0-201-06673-4 :π}ππProcedure RadixExchange(l, r, b:Integer);πVarπ t, i, j : Integer;πbeginπ if (r > l) and (b >= 0) thenπ beginπ i := l;π j := r;π Repeatπ While (bits(a[i], b, 1) = 0) and (i < j) doπ i := I + 1;π While (bits(a[j], b, 1) = 1) and (i < j) doπ j := j - j;π t := a[i];π a[i] := a;π a[j] := t;π Until (j = i);π if bits(a[r], b, 1) = 0 thenπ j := j + 1;π RadixExchange(l, (j - 1), b - 1);π RadixExchange(j, r, (b - 1));π end;πend;ππ{π>By toggling the high bit, the Integers are changed in a way that,π>conveniently, allows sorting by magnitude: from the "most negative"π>to "most positive," left to right, using an Array With unsignedπ>indexes numbering 0...FFFFh.ππ ...Why bother With the bit toggling at all? Why not just defineπ the Array's range as being: Array[-32768..32767] of Byte;π}ππ 22 05-28-9313:57ALL SWAG SUPPORT TEAM RADIXQUE.PAS IMPORT 16 S9á Turbo Pascal Optimization Contest # 51.ππNo tangible prizes, just some bragging rights, and a brain workout.ππAssignment: Write conversion routines similar to VAL and STR that canπ handle a radix (base) of any number. For example, below isπ a straight Pascal Procedure to convert a String of any baseπ to a LongInt. Can you improve the speed of this routine,π and Write a correspondingly fast routine to convert from aπ LongInt to a String of any base?ππRules: No rules. BAsm is allowed, as long as the Functions areπ readily Compilable without the use of TAsm.ππJudging: Code will be tested on a 386-40 on March 10th, by beingπ placed into a loop With no output, like this:ππ StartTiming;π For Loop := 1 to 10000000 { ten million } doπ { Execute the test, no output }π WriteLn(StopTiming);ππReady, set, code! Here's the sample...ππ(* This Function converts an ASCIIZ String S in base Radix to LongInt Iπ * With no verification of radix validity. The calling Programmer isπ * responsible For insuring that the radix range is 2 through 36. Theπ * calling Programmer is also responsible For insuring that the passedπ * String contains only valid digits in the specified Radix. No checkingπ * is done on the individual digits of a given String. For bases 11-36π * the letters 'A'-'Z' represent the corresponding values.π *)ππProcedure StrtoLong(Var I : LongInt; S : PChar; Radix : Integer);π beginπ I := 0;π While S[0] <> #0 doπ beginπ Case S[0] of '0'..'9' : I := I * Radix + (ord(S[0])-48);π 'A'..'Z' : I := I * Radix + (ord(S[0])-54);π 'a'..'z' : I := I * Radix + (ord(S[0])-86);π Inc(s);π end;π end;ππ 23 05-28-9313:57ALL JOY MUKHERJEE Radix Sort IMPORT 24 SÇ^ {π> I agree... unFortunately the Radix algorithm (which is aπ> sophisticated modification of a Distribution Sort algorithm) isπ> very Complex, highly CPU dependent and highly data dependent.ππWe must be speaking of a different Radix Sort. Is the sort you areπtalking about sort numbers on the basis of their digits?ππ> My understanding is that a Radix sort cannot be implemented inπ> Pascal without using a majority of Asm (which means you might asπ> well code the whole thing in Asm.)ππ> assembly) or dig up some working code, I would love to play With it!ππ************************************************************************π* *π* Name : Joy Mukherjee *π* Date : Mar. 26, 1990 *π* Description : This is the Radix sort implemented in Pascal *π* *π************************************************************************π}ππProgram SortStuff;ππUses Crt, Dos;ππTypeπ AType = Array [1..400] of Integer;π Ptr = ^Node;π Node = Recordπ Info : Integer;π Link : Ptr;π end;π LType = Array [0..9] of Ptr;ππVarπ Ran : AType;π MaxData : Integer;ππProcedure ReadData (Var A : AType; Var MaxData : Integer);ππVar I : Integer;ππbeginπ MaxData := 400;π For I := 1 to 400 do A [I] := Random (9999);πend;ππProcedure WriteArray (A : AType; MaxData : Integer);ππVar I : Integer;ππbeginπ For I := 1 to MaxData doπ Write (A [I] : 5);π Writeln;πend;ππProcedure Insert (Var L : LType; Number, LN : Integer);ππVarπ P, Q : Ptr;ππbeginπ New (P);π P^.Info := Number;π P^.Link := Nil;π Q := L [LN];π if Q = Nil thenπ L [LN] := Pπ elseπ beginπ While Q^.Link <> Nil doπ Q := Q^.Link;π Q^.Link := P;π end;πend;πππProcedure Refill (Var A : AType; Var L : LType);πVarπ I, J : Integer;π P : Ptr;πbeginπ J := 1;π For I := 0 to 9 doπ beginπ P := L [I];π While P <> Nil doπ beginπ A [J] := P^.Info;π P := P^.Link;π J := J + 1;π end;π end;π For I := 0 to 9 doπ L [I] := Nil;πend;ππProcedure RadixSort (Var A : AType; MaxData : Integer);πVarπ L : LType;π I,π divisor,π ListNo,π Number : Integer;πbeginπ For I := 0 to 9 do L [I] := Nil;π divisor := 1;π While divisor <= 1000 doπ beginπ I := 1;π While I <= MaxData doπ beginπ Number := A [I];π ListNo := Number div divisor MOD 10;π Insert (L, Number, ListNo);π I := I + 1;π end;π Refill (A, L);π divisor := 10 * divisor;π end;πend;ππbeginπ ReadData (Ran, MaxData);π Writeln ('Unsorted : ');π WriteArray (Ran, MaxData);π RadixSort (Ran, MaxData);π Writeln ('Sorted : ');π WriteArray (Ran, MaxData);πend.π 24 05-28-9313:57ALL SWAG SUPPORT TEAM SHELL1.PAS IMPORT 14 S*K { Arrrggghh. I hate Bubble sorts. Why don't you use Merge sort? It's a hellπ of a lot faster and if you have a large enough stack, there wouldn't beπ any problems. if you were not interested in doing a recursive sort, thenπ here is an example fo the Shell sort which is one of the most efficientπ non recursive sorts around.π}πππConstπ Max = 50;πTypeπ ArrayType = Array[1..Max] of Integer;ππVarπ Data, Temp : ArrayType;π Response : Char;π X, Iteration : Integer;ππProcedure ShellSort (Var Data : ArrayType;Var Iteration : Integer;π NumberItems : Integer);ππProcedure Sort (Var Data : ArrayType; Var Iteration : Integer;π NumberItems, Distance : Integer);ππVarπ X, Y : Integer;ππbegin {Sort}π Iteration := 0;π For Y := Distance + 1 to NumberItems Doπ begin {For}π X := Y - Distance;π While X > 0 Doπ begin {While}π if Data[X+Distance] < Data[X] thenπ begin {if}π Switch (Data[X+Distance], Data[X], Iteration);π X := X - Distance;π Iteration := Iteration + 1π end {if}π elseπ X := 0;π end; {While}π end {For}πend; {Sort}ππbegin {ShellSort}π Distance := NumberItems div 2;π While Distance > 0 doπ begin {While}π Sort (Data, Iteration, NumberItems, Distance);π Distance := Distance div 2π end; {While}πend; {ShellSort}π 25 05-28-9313:57ALL SWAG SUPPORT TEAM SOMESORT.PAS IMPORT 18 Sú { Author: Brian Pape. }ππConstπ maxrange = 5000;ππTypeπ ListRange = 1..MaxRange;π list = Array[ListRange] of Integer;ππVarπ a,b: list;π i: Integer;ππProcedure BubbleSort(Var B : list; Terms : Integer);πVarπ J, Temp : Integer;π Changed : Boolean;π Last,π LastSwitch : Integer;πbeginπ changed := True;π Last := Terms-1;π While Changed doπ beginπ changed := False;π For J := 1 to Last doπ If B[J] > B[J+1] thenπ beginπ Temp := B[J];π B[J] := B[J+1];π B[J+1] := Temp;π Changed := True;π LastSwitch := j;π end; { If B[J] }π Last := LastSwitch -1;π end { While Changed }πend; { BubbleSort }ππProcedure Min_MaxSort(Var a : list; NumberTerms : ListRange);πVarπ temp,π i,l,r,π min,max,π tempMin,π tempMax,π indexMin,π indexMax,π s1,s2,s3,s4 : Integer;π changed : Boolean;πbeginπ l := 1; r := NumberTerms; max := MaxInt;π Repeatπ min := max;π changed := False;π max := 0;π For i := l to r doπ beginπ if a[i] > max thenπ beginπ changed := True;π Max := a[i];π indexMax := i;π end; { if }π if a[i] < min thenπ beginπ changed := True;π Min := a[i];π indexMin := i;π end; { if }π end; { For }ππ tempMin := a[indexMin];π tempMax := a[indexMax];π a[indexMax] := a[l];π a[l] := tempMin;π a[indexMin] := a[r];π a[r] := tempMax;π inc(l); dec(r);π Until (l>=r) or not changed;πend; { Min_MaxSort }πππProcedure ShellSort(Var a : list; NumberTerms : ListRange);πConstπ start = 1;π increment = 3; { division factor of terms }πVarπ i,j : ListRange;π t : Integer;π found : Boolean;πbeginπ i := start + increment;π While i <= NumberTerms doπ beginπ if a[i] < a[i - increment] thenπ beginπ j := 1;π t := a[i];π Repeatπ j := j - increment;π a[j + increment] := a[j];π if j = 1 thenπ found := Trueπ elseπ found := a[j - increment] <= t;π Until found;π a[j] := t;π end; { if }π i := i + increment;π end; { While }πend; { ShellSort }π 26 05-28-9313:57ALL SWAG SUPPORT TEAM SORT-DLL.PAS IMPORT 25 S╬ {π> Now, I gotta work on sortin' em. I believe I can 'swap' theπ> positions of the Pointers eh?π>π> I can't figure out how to swap the Pointers. Could you pleaseπ> gimme a wee bit more help? I've just started doing sorts, andπ> have only used the Bubble sort at the moment in a few Programs,π> so I'm still a little shakey on sorts. I understand the Bubbleππ Here's an *example* on how to sort a linked list. There are moreπ efficient ways to sort a list, but this gives you all theπ essential elements in doing a sort. (note that ListPtr is a doublyπ linked list)π}ππProcedure SortList(Var FCL:ListPtr);πVarπ TempAnchor, TemPtr1, TemPtr2 :ListPtr;ππ Procedure MoveLink(Var Anchor, Ptr1, Ptr2 :ListPtr);π Varπ TemPtr3, TemPtr4 :ListPtr;π beginπ TemPtr3 := Ptr1^.Next; { temporary Pointer preserves oldπ Pointer value }π TemPtr4 := Ptr2^.Last; { ditto }ππ Ptr2^.Last := Ptr1; { do the Pointer swap }π Ptr1^.Next := Ptr2;ππ Ptr1^.Last^.Next := TemPtr3; { fixup secondary Pointers }π TemPtr3^.Last := Ptr1^.Last;π Ptr1^.Last := TemPtr4;ππ if TemPtr4 <> NIL then { if temporary Pointer is notπ NIL, then it has to point toπ swapped Pointer }π TemPtr4^.Next := Ptr1;ππ if Ptr1^.Last = NIL then { if swapped Pointer points toπ preceding NIL Pointer, thisπ Pointer is the new root. }π Anchor := Ptr1;π end;ππbeginπ TempAnchor := FCL; { holds root of list during sort }π TemPtr2 := TempAnchor; { TemPtr2 points to current data beingπ Compared }π Repeatπ TemPtr1 := TemPtr2; { TemPtr1 points to the next orderedπ data }π FCL := TemPtr2; { start FCL at root of UNSorTED list -π sorted data precede this Pointer }π Repeatπ FCL := FCL^.Next;π if FCL^.data < TemPtr1^.data then { Compare data values }π TemPtr1 := FCL; { if necessary, reset TemPtr1 toπ point to the new ordered value }π Until FCL^.Next = NIL; { keep going Until you reach theπ end of the list. After Exit,π the next value in order will beπ pointed to by TemPtr1 }π if TemPtr1<>TemPtr2 then { if TemPtr1 changed, a valueπ was found out of order }π MoveLink(TempAnchor,TemPtr1,TemPtr2) { then swap Pointers }π elseπ TemPtr2 := TemPtr2^.Next; { else advance to the nextπ Pointer in list }π Until TemPtr2^.Next = NIL; { Until we are finished sortingπ the list }π FCL := TempAnchor; { changes root Pointer to new root value }πend;ππ 27 05-28-9313:57ALL SWAG SUPPORT TEAM SORT-LL.PAS IMPORT 25 Sìf {π> I have a linked list structure that I would like to sort in one ofπ> four different ways. I can sort Arrays using QuickSort, etc., but have noπ> experience sorting linked lists. Does anyone have any source codeπ> (preferably) or any suggestions on how to proceed? Any help would beπ> appreciated.ππI got Modula-2 code I wrote about one year ago. I post an excerpt fromπthe Implementation MODULE. It should be no problem to convert it toπPascal, since the languages are rather similar.π}πProcedure LISTSort(Var List : LISTType;π Ascending: Boolean);ππVarπ Last : NodeTypePtr;π Result: LISTCompareResultType;ππ Procedure TailIns( Rec : NodeTypePtr;π Var First: NodeTypePtr;π Var Last : NodeTypePtr);ππ beginπ if (First=NIL) then First := Rec else Last^.Next := Rec end;π Last := Recπ end TailIns;ππ Procedure MergeLists( a: NodeTypePtr;π b: NodeTypePtr): NodeTypePtr;ππ Varπ First: NodeTypePtr;π Last : NodeTypePtr;π Help : NodeTypePtr;ππ beginπ First := NIL;π While (b#NIL) doπ if (a=NIL) thenπ a := b; b := NILπ elseπ if (Classes[List^.ClassID].Cmp(b^.DataPtr,a^.DataPtr)=Result)π thenπ Help := a; a := a^.Nextπ elseπ Help := b; b := b^.Nextπ end;π Help^.Next := NIL;π TailIns(Help,First,Last)π endπ end;π TailIns(a,First,Last);π RETURN(First)π end MergeLists;ππ Procedure MergeSort(Var Root: NodeTypePtr;π N : CARDinAL): NodeTypePtr;ππ Varπ Help: NodeTypePtr;π a,b : NodeTypePtr;ππ beginπ if (Root=NIL) thenπ RETURN(NIL)π ELSif (N>1) thenπ a := MergeSort(Root,N div 2);π b := MergeSort(Root,(N+1) div 2);π RETURN(MergeLists(a,b))π elseπ Help := Root;π Root := Root^.Next;π Help^.Next := NIL;π RETURN(Help)π endπ end MergeSort;ππbeginπ if (List^.N<2) then RETURN end;π if (Ascending) then Result := LISTGreater else Result := LISTLess end;π List^.top^.Next := MergeSort(List^.top^.Next,List^.N);π Last := List^.top;π List^.Cursor := List^.top^.Next;π While (List^.Cursor#NIL) doπ List^.Cursor^.Prev := Last;π Last := List^.Cursor;π List^.Cursor := List^.Cursor^.Nextπ end;π Last^.Next := List^.Bottom;π List^.Bottom^.Prev := Last;π List^.CurPos := 1;π List^.Cursor := List^.top^.Nextπend LISTSort;ππ{πThe basic data structure is defined as follows:π}ππConstπ MaxClasses = 256;ππTypeπ NodeTypePtr = Pointer to NodeType;ππ NodeType = Recordπ Prev : NodeTypePtr;π Next : NodeTypePtr;π DataPtr: ADDRESSπ end;ππ LISTType = Pointer to ListType;ππ ListType = Recordπ top : NodeTypePtr;π Bottom : NodeTypePtr;π Cursor : NodeTypePtr;π N : CARDinAL;π CurPos : CARDinAL;π ClassID: CARDinALπ end;ππ ClassType = Recordπ Cmp : LISTCompareProcType;π Bytes: CARDinALπ end;ππVarπ Classes: Array [0..MaxClasses-1] of ClassType;π 28 05-28-9313:57ALL SWAG SUPPORT TEAM SORT-PTR.PAS IMPORT 11 S╙░ {π This is using the concept of a PoINter Array (an Array of PoINters). Itπallows For a _very_ large amount of data, sINce you allocate each Record spaceπof the Heap. You must allocate each space For each Record as you create theπRecord:π}ππ New (INFOSTUFF[3]); { allocates space For 3rd Record }π With INFOSTUFF[6]^ do { works With 6th Record }π beginπ NAME := 'Patrick Edwards'; IDNUM := 60000; MOM := ''π end;ππ The sort could be:ππVar T : INFO;πProcedure L_HSorT (LEFT,RIGHT : Word); { Lo-Hi QuickSort }πVar LOWER,UPPER,MIDDLE : Word;π PIVOT : INFO;πbeginπ LOWER := LEFT; UPPER := RIGHT; MIDDLE := (LEFT+RIGHT) div 2;π PIVOT := INFOSTUFF[MIDDLE]^;π Repeatπ While INFOSTUFF[LOWER]^.NAME < PIVOT.NAME do INc(LOWER);π While PIVOT.NAME < INFOSTUFF[UPPER]^.NAME do Dec(UPPER);π if LOWER <= UPPER thenπ beginπ T := INFOSTUFF[LOWER]^; INFOSTUFF[LOWER]^ := INFOSTUFF[UPPER]^;π INFOSTUFF[UPPER]^ := T;π INc (LOWER); Dec (UPPER);π end;π Until LOWER > UPPER;π if LEFT < UPPER then L_HSorT (LEFT, UPPER);π if LOWER < RIGHT then L_HSorT (LOWER, RIGHT);πend; { L_HSorT }ππ{ called as:ππL_HSorT (1,10);π}π 29 05-28-9313:57ALL SWAG SUPPORT TEAM SORT-STR.PAS IMPORT 7 Sσá {πIt gets better and better. The Procedure below is incredibly fast in theπsorting of the Strings in the Arrays! 1.2 sec For 1485 Strings.π}ππProcedure Sort(item : PFilearr; Last : Integer);πVarπ i, j : Integer;π span : Integer;πbeginπ item^[0] := newstr(' ');π span := Last shr 1; {Span=Last/2}π While span > 0 doπ beginπ For i := Span to Last - 1 doπ beginπ For j := (i - Span + 1) downto 1 doπ if item^[j]^ <= item^[j + Span]^ thenπ j:=1 {to make it quit the j-loop}π elseπ begin {swap Array(j) With Array(j+Span)}π item^[0] := item^[j];π item^[j] := item^[j + Span];π item^[j + Span] := item^[0];π end;π end;π Span := Span shr 1; {Span=Span/2}π end;πend;π 30 05-28-9313:57ALL SWAG SUPPORT TEAM SORTFAST.PAS IMPORT 21 S} {π> I might share With you a sorting Procedure which I developed Forπ> 'those Arrays we were talking about:π> ...π> Exeperimentally I used it on 1485 Strings, which took about 3 secπ> on my 386DX40. Could you advise on some method to do it evenπ> faster?ππI'll share With you a little sort routine which I use often in my Programsπwhenever I need a fast and efficient routine With very low overhead... It Usesπconsiderably less code than your example, and should outperForm it. (It wouldπbe even faster if it was all coded in Assembly!-- hint hint DJ) :-)π}ππProcedure Sort_It( totalItems : Word );ππ Function Is_Less( TemPtr1, TemPtr2 : Pointer ) : Boolean;π beginπ Is_Less := ( YourStruct(TemPtr1^).Item < YourStruct(TemPtr2^).Item );π end;ππVarπ I,J : Word;π Cur : Word;ππbeginπ For I := 1 to Pred(totalItems) doπ beginπ Cur := I;ππ For J := I + 1 to totalItems doπ if Is_Less( Item[J], Item[Cur] ) thenπ ExchangeLongInts( LongInt(Item[J]), LongInt(Item[Cur]) );π end; { For }ππend; { Proc }ππ{πThere's a couple things I should explain: The "ExchangeLongInts" Procedure isπfrom the TurboPower Opro's OpInline Unit. All it does is exchange two LongIntπTypes without you having to use a temporary Variable. It's fast and convenient,πbut not the only possible solution here. (I'm Typecasting the Pointer into aπLongInt For a 4-Byte swap.)ππ"totalItems" is the total number of items in your Array to sort.ππ"Item" is the actual Array; Item : Array[1..xx] of Pointer_to_Record;ππ"YourStruct" used in the "Is_Less" Function is Typecasting the actual structureπor Record that "Item" is referring to. It's the only portion of the code whichπlooks at your actual data. to reverse the sort order, simply change the "<" toπ">". to change what is being sorted, just change the ".Item" to something elseπlike ".Name" or ".Zip" or whatever else might be contained in your structure.ππThis routine is simple, has a minimum amount of code, Uses very little stack,πworks only With Pointers and you are only sorting memory addresses; it neverπactually move any of your physical data. (if you did, then it would be slow.)ππIt'll sort several thousand items in only a couple seconds even on slowerπmachines, and is super on small volume runs. I would imagine that it wouldπ(90 min left), (H)elp, More? start loosing steam around 1,000 to 2,000 items, but For me, it's the bestπchoice when memory is at a premium and the Arrays are fairly small.π}ππ 31 05-28-9313:57ALL SWAG SUPPORT TEAM TIMESORT.PAS IMPORT 69 S╬ {I wrote a small Program to bench both sort routines we posted. It was anπinteresting test, however it did raise a couple questions For me, which I'llπget to in a moment. (The following Program can be used as a skeleton For tryingπother sort routines too.)ππNeedless to say, the routine you posted was dramatically faster than the one Iπposted, even though both routines are non-recursive simple sorts.ππThe maximum efficient load of the routine you posted appears to be about 3000πelements. After that, additonal elements add time exponentially. For example,πit will sort 3000 elements in 5.1 seconds, but 5000 elements takes almost 16πseconds. The sort I posted became un-benchable [bearable] at about 3000πelements when it took over a minute to Complete. I didn't test it beyond thisπpoint.ππHere are the results from my 386 33Mhz machine-- your algorithm.ππ 500 Elements - 0.1 Secondsπ 1000 Elements - 0.8 Secondsπ 1500 Elements - 1.4 Secondsπ 2000 Elements - 2.6 Secondsπ 3000 Elements - 5.1 Seconds <- Peak efficiency reachedπ 5000 Elements - 15.8 SecondsππHere is the Program I used to benchmark with. I made it so that you couldπ"tweak" portions of the sort and re-run the Program.ππIncidentally, I also Compiled this Program under Stony Brook's Pascal Plus andπwas suprised to find that it ran substantially slower. All optimizations on.ππRange Checking ($R+) exactly Doubled the time it took to sort.ππChanging "Span+1" to Succ(Span) and "total-1" to Pred(total) made the routineπabout 3% faster. However the routine then neglected to sort that last twoπelements. Adding "Inc(total,2)" solved the problem but I'm not sure why. I didπnot expect this behavior. Perhaps someone could explain why?ππI added a temporary Pointer Variable to your routine in place of the "NewStr('π... ')" code you used to simplify it.ππand one last thing... Using OPRO's OpInline Function calledπ"ExchangeLongInts()" to do the swapping instead of using a temporary Varπincreased speed another 2% (Evident at > 2000 elements.) However I did notπinclude this so that anyone interested could Compile and run this without extraπUnits.π}ππ{$A+,B-,D-,E-,F-,G-,I+,L+,N-,O-,P-,Q+,R-,S+,T-,V-,X-,Y+}π{$M 32768,0,655360}ππProgram Sort_Test; { Sorting Benchmark Using P. Beeftink's Algorithm }ππTypeπ SmallArrPtr = ^SmallArr;π SmallArr = Array[1..10] of Char; { Skip String & Length Byte }ππ TTimeString = String[20];πππVarπ SortArray : Array[1..5000] of SmallArrPtr; { A LARGE Array }ππ TickCount : LongInt Absolute $0040:$006C;π { TickCount : LongInt VOLATILE Absolute $0040:$006C; } { For Pascal+ }π Tstart,π Ttime : LongInt;ππ{------------------------------------------------------------------------}πProcedure StartTiming;πbeginπ TStart := TickCount;ππ {start at the beginning of a tick!}π Repeat Until TStart <> TickCount;ππ TStart := TickCount;ππend;π{------------------------------------------------------------------------}πProcedure StopTiming;πbeginπ TTime := TickCount - TStart;πend;π{------------------------------------------------------------------------}πFunction Elapsed : TTimeString;πVar Temp : TTimeString;π Sec10 : LongInt;πbeginππ Sec10 := TTime * 2470 div 4497;π Str( Sec10 : 4, Temp );ππ if Temp[1] = ' ' then Temp[1] := '0';ππ Inc( Temp[0] );π Temp[ Length(Temp) ] := Temp[ Pred( Length( Temp ) ) ];π Temp[ Pred( length( Temp ) ) ] := '.';ππ Elapsed := Temp;πend;π{------------------------------------------------------------------------}πProcedure MakeRandomStrings( NumtoMake : Word );πVar RNum,π I,S : Word;π Temp : String;πbeginππ Temp := '';π Temp[0] := Chr( 10 );π Randomize;ππ For I := 1 to NumtoMake doπ beginππ For S := 1 to 10 do { Create Random Strings 10 Chars in length }π beginπ RNum := Random(26);π Temp[S] := Chr( RNum + 65 );π end;ππ Move( Temp[1], SortArray[I]^, 10 );ππ end;ππend; { Proc }π{------------------------------------------------------------------------}πProcedure KDSort( total : Word );π {-My simple sort routine as posted in Pascal Echo }π { With 2 slight modifications }πVarπ i,j,π Current : Word;π TempPtr : Pointer;πbeginππ For I := 1 to total doπ beginππ Current := I;ππ For J := Succ(I) to total doπ beginπ if SortArray[J]^ < SortArray[Current]^ thenπ beginπ TempPtr := SortArray[j];π SortArray[j] := SortArray[Current];π SortArray[Current] := TempPtr;π end; {if}π end; {For}ππ end; {For}ππend;π{------------------------------------------------------------------------}πProcedure PBSort(total : Integer);π {-Peter Beeftink's Sort as Posted in Pascal Echo }π { Also With slight modifications }πVarπ I,j : Integer;π Span : Integer;π TempPtr : Pointer;πbeginππ Inc(total,2); { Required to Compensate For PRED and SUCC ? }ππ Span := total SHR $01;ππ While Span > 0 doπ beginππ For I := Span to Pred(total) {total-1} doπ beginππ For j := (I - Succ(Span) {Span+1} ) Downto 1 doπ if (SortArray[j]^ <= SortArray[j+Span]^) then j := 1 elseπ beginπ TempPtr := SortArray[j];π SortArray[j] := SortArray[j+Span];π SortArray[j+Span] := TempPtr;π end;ππ end; {For}ππ Span := Span SHR $01; { This does help speed over Span div 2! }ππ end; {WhIle}ππend;π{------------------------------------------------------------------------}πProcedure Do_Sorting( SortAmount : Word );πbeginππ MakeRandomStrings(SortAmount);ππ Write('Sorting... ');ππ StartTiming;ππ PBSort(SortAmount); { Change to KDSort() to bench second sort routine }ππ StopTiming;ππ WriteLn(SortAmount:5,' Elements - ',Elapsed,' Seconds');ππend;π{------------------------------------------------------------------------}πVar C : Word;ππbeginππ if MaxAvail < 5000 * Sizeof(SmallArr) then Halt; { not enough memory! }ππ For C := 1 to 5000 do { pre-allocate up front }π GetMem(SortArray[C],Sizeof(SmallArr));πππ Do_Sorting( 500 ); { Add more Do_Sorting()'s For whatever count }π Do_Sorting( 1000 ); { you wish to test with. }π Do_Sorting( 1500 );π Do_Sorting( 2000 );π Do_Sorting( 3000 );π Do_Sorting( 5000 );πππ { Un-comment the following if you wish to see the sorted output }ππ {π For C := 1 to 5000 do { Change 5000 to the amount you sorted }π WriteLn( SortArray[C]^ );πππ For C := 1 to 5000 doπ FreeMem(SortArray[C],Sizeof(SmallArr));ππend.π{πI plugged in a QuickSort algorithm in the "skeleton" Program in my previousπmessage to test perFormance. Here are the results:ππ 500 Elements - 0.1 Secondsπ 1000 Elements - 0.2 Secondsπ 1500 Elements - 0.4 Secondsπ 2000 Elements - 0.6 Secondsπ 3000 Elements - 0.9 Secondsπ 5000 Elements - 1.8 SecondsππVery fast indeed. I modified the algorithm to sort only by Pointers, andπoptimized a couple spots. Again, a slight speed increase is noted using OPRO'sπExchangeLongInts() in leu of using temporary Variables in 1 spot. if you haveπOPRO, replace them and you reduce the number of instructions by 2 perπiteration.ππThis is a split-list recursive sort. Works by making a pass through the entireπArray first and moves all "small" data to the left, and all "Large" data to theπright. then it sorts each half seperately.ππTake the following code segment and "plug" it into the skeleton in my previousπmessage. then change the "PBSort(SortAmount)" to "QuickSort(SortAmount)" to runπthe tests.ππHere is the code segment:ππ{------------------------------------------------------------------------}πProcedure QuickSort( total : Integer );π {------------------------------------------}π Procedure recQuickSort( L, R : Integer );π Var K,I,J : Integer;π T,π Temp : Pointer;ππ beginππ if L < R thenπ beginπ T := SortArray[L];π I := Pred(L);π J := L;π K := Succ(R);ππ While Succ(J) < K doπ if SortArray[Succ(J)]^ < SmallArrPtr(T)^ thenπ beginπ Inc(I,1);π Inc(J,1);π SortArray[I] := SortArray[J];π SortArray[j] := T;π end {if}π elseπ if SortArray[Succ(J)]^ > SmallArrPtr(T)^ thenπ beginπ Dec(K,1);π Temp := SortArray[K];π SortArray[K] := SortArray[Succ(J)];π SortArray[Succ(J)] := Temp;π end {if}π elseπ Inc(J,1);ππ recQuickSort(L,I);π recQuickSort(K,R);ππ end; { if L < R }ππ end; { Proc recQuickSort }π {------------------------------------------}ππbeginππ recQuickSort(1,total);ππend;{QuickSort}π{------------------------------------------------------------------------}π 32 05-31-9307:15ALL GUY MCLOUGHLIN Various SORT Methods IMPORT 45 S╥Æ constπ MaxItem = 30000;ππtypeπ Item = word;π Ar1K = array[1..MaxItem] of Item;πππ (***** Selection sort routine. *)π (* *)π procedure SelectionSort ({update} var Data : Ar1K;π {input } ItemsToSort : word);π varπ Temp : Item;π Min,π Index1,π Index2 : word;π beginπ for Index1 := 1 to pred(ItemsToSort) doπ beginπ Min := Index1;π for Index2 := succ(Index1) to ItemsToSort doπ if Data[Index2] < Data[Min] thenπ Min := Index2;π Temp := Data[Min];π Data[Min] := Data[Index1];π Data[Index1] := Tempπ endπ end; (* SelectionSort. *)πππ (***** Insertion sort routine. *)π (* *)π procedure InsertionSort ({update} var Data : Ar1K;π {input } ItemsToSort : word);π varπ Temp : Item;π Index1,π Index2 : word;π beginπ for Index1 := 2 to ItemsToSort doπ beginπ Temp := Data[Index1];π Index2 := Index1;π while (Data[pred(Index2)] > Temp) doπ beginπ Data[Index2] := Data[pred(Index2)];π dec(Index2)π end;π Data[Index2] := Tempπ endπ end; (* InsertionSort. *)πππ (***** Bubble sort routine. *)π (* *)π procedure BubbleSort ({update} var Data : Ar1K;π {input } ItemsToSort : word);π varπ Temp : Item;π Index1,π Index2 : word;π beginπ for Index1 := ItemsToSort downto 1 doπ for Index2 := 2 to Index1 doπ if (Data[pred(Index2)] > Data[Index2]) thenπ beginπ Temp := Data[pred(Index2)];π Data[pred(Index2)] := Data[Index2];π Data[Index2] := Tempπ endπ end; (* BubbleSort. *)ππ (***** Shell sort routine. *)π (* *)π procedure ShellSort ({update} var Data : Ar1K;π {input } ItemsToSort : word);π varπ Temp : Item;π Index1, Index2, Index3 : word;π beginπ Index3 := 1;π repeatπ Index3 := succ(3 * Index3)π until (Index3 > ItemsToSort);π repeatπ Index3 := (Index3 div 3);π for Index1 := succ(Index3) to ItemsToSort doπ beginπ Temp := Data[Index1];π Index2 := Index1;π while (Data[(Index2 - Index3)] > Temp) doπ beginπ Data[Index2] := Data[(Index2 - Index3)];π Index2 := (Index2 - Index3);π if (Index2 <= Index3) thenπ breakπ end;π Data[Index2] := Tempπ endπ until (Index3 = 1)π end; (* ShellSort. *)πππ (***** QuickSort routine. *)π (* *)π procedure QuickSort({update} var Data : Ar1K;π {input } Left,π Right : word);π varπ Temp : Item;π Index1, Index2, Pivot : word;π beginπ Index1 := Left;π Index2 := Right;π Pivot := Data[(Left + Right) div 2];π repeatπ while (Data[Index1] < Pivot) doπ inc(Index1);π while (Pivot < Data[Index2]) doπ dec(Index2);π if (Index1 <= Index2) thenπ beginπ Temp := Data[Index1];π Data[Index1] := Data[Index2];π Data[Index2] := Temp;π inc(Index1);π dec(Index2)π endπ until (Index1 > Index2);π if (Left < Index2) thenπ QuickSort(Data, Left, Index2);π if (Index1 < Right) thenπ QuickSort(Data, Index1, Right)π end; (* QuickSort. *)ππ (***** Radix Exchange sort routine. *)π (* *)π procedure RadixExchange ({update} var Data : ar1K;π {input } ItemsToSort,π Left,π Right : word;π BitNum : shortint);π varπ Temp : Item;π Index1, Index2 : word;π beginπ if (Right > Left) and ( BitNum >= 0) thenπ beginπ Index1 := Left;π Index2 := Right;π repeatπ while (((Data[Index1] shr BitNum) AND 1) = 0)π and (Index1 < Index2) doπ inc(Index1);π while (((Data[Index2] shr BitNum) AND 1) = 1)π and (Index1 < Index2) doπ dec(Index2);π Temp := Data[Index1];π Data[Index1] := Data[Index2];π Data[Index2] := Tempπ until (Index2 = Index1);π if (((Data[Right] shr BitNum) AND 1) = 0) thenπ inc(Index2);π RadixExchange(Data, ItemsToSort, Left, pred(Index2),π pred(BitNum));π RadixExchange(Data, ItemsToSort, Index2, Right, pred(BitNum))π endπ end; (* RadixExchange. *)πππ(*π - Guyπ---π ■ DeLuxe²/386 1.25 #5060 ■ππ*) 33 08-27-9319:59ALL GREGORY P. SMITH Alpha Sorting IMPORT 30 S {πGREGORY P. SMITHππ> Well, that's easier said than done ! So far I've accomplished aπ> selection sort which takes about 10-15 minutes For 1000 Records, and I'mπ> gonna be needin to sort about 5000 For the Programz intended applicationπ> !!! Also the place that I'm writing this For has an 8088 With 640K RAMπ> <chuckle> !!! Could you pleez tell me how to do a merge sort <is thatπ> easier than quicksortππHere is an example followed by an exlpanation.π}ππTypeπ ListPtr = ^List;π List = Recordπ next : ListPtr; { next node }π str : String; { data to sort }π end;ππ{ Splits List l into two half lists, h1 & h2 }πProcedure SplitList(l : ListPtr; Var h1, h2 : ListPtr);πVarπ listone : Boolean;π tmp : ListPtr;πbeginπ h1 := nil;π h2 := nil;π listone := True; { start With first list }π While l <> nil doπ beginπ tmp := l^.next; { save next node to split }π if listone thenπ begin { insert a node in the first list }π l^.next := h1;π h1 := l; { keep h1 at head }π endπ elseπ begin { insert a node in the second list }π l^.next := h2;π h2 := l; { keep h2 at head }π end;π l := tmp; { move to next node }π listone := not listone; { alternate lists to insert into }π end;πend; { SplitList }ππ{----------------- Merge Sort -------------------}ππ{ merges sorted l1 & l2 into one sorted list (alphabetically) }πFunction MergeAlphaLists(l1, l2 : ListPtr) : ListPtr;πVarπ tmp : ListPtr; { resulting list }πbeginπ if (l1 = nil) thenπ tmp := l2π elseπ if (l2 = nil) thenπ tmp := l1π elseπ if l1^.str < l2^.str thenπ begin { lesser node first }π tmp := l1;π l1 := l1^.next;π endπ elseπ beginπ tmp := l2;π l2 := l2^.next;π end;π MergeAlphaLists := tmp; { return head of merged sorted list }π While (l1 <> nil) and (l2 <> nil) do { traverse lists }π if l1^.str < l2^.str thenπ beginπ tmp^.next := l1; { add the lesser node }π tmp := l1; { move ahead }π l1 := l1^.next; { next node }π endπ elseπ beginπ tmp^.next := l2; { add the lesser node }π tmp := l2; { ahead 1 }π l2 := l2^.next; { next node }π end;π if (l1 <> nil) thenπ tmp^.next := l1 { append remaining nodes }π elseπ tmp^.next := l2;πend; { MergeAlphaLists }ππ{ Sorts list l alphabetically }πFunction MergeSortAlpha(l : ListPtr) : ListPtr;πVarπ sl1,π sl2 : ListPtr;πbeginπ if l <> nil then { empty list? }π if l^.next <> nil thenπ begin { single node list? }π inc(progress);π SplitList(l, sl1, sl2); { split list into two halves }π sl1 := MergeSortAlpha(sl1); { sort the first half }π sl2 := MergeSortAlpha(sl2); { sort the second half }π MergeSortAlpha := MergeAlphaLists(sl1, sl2) { combine sorted lists }π endπ elseπ MergeSortAlpha := l { single node is already sorted }π elseπ MergeSortAlpha := nilπend;ππ{πWhat mergesort does is to split the list into two equal halves. It thenπmergesorts each of these halves, and merges them back together. The Real workπis done in the merging step. When the lists are split down to the level ofπsingle node lists they are merged together again in the correct order. As itπpops out of the recursion the larger lists are sorted so that merging willπstill keep them in order because each node is > than the previous one. This isπprobably the most widely used sorting algorithm (don't quote me) because it isπsimple but delivers n*log(n) performance like any good algorithm would.π}π 34 08-27-9320:16ALL NIKLAUS WIRHT Classic Quicksort IMPORT 35 S {π> Can you show me any version of thew quick sort that you may have? I'veπ> never seen it and never used it before. I always used an insertion sortπ> For anything that I was doing.ππHere is one (long) non-recursive version, quite fast.π}ππTypeπ _Compare = Function(Var A, B) : Boolean;{ QuickSort Calls This }ππ{ --------------------------------------------------------------- }π{ QuickSort Algorithm by C.A.R. Hoare. Non-Recursive adaptation }π{ from "ALGORITHMS + DATA STRUCTURES = ProgramS" by Niklaus Wirth }π{ Prentice-Hall, 1976. Generalized For unTyped arguments. }π{ --------------------------------------------------------------- }ππProcedure QuickSort(V : Pointer; { To Array of Records }π Cnt : Word; { Record Count }π Len : Word; { Record Length }π ALessB : _Compare); { Compare Function }ππTypeπ SortRec = Recordπ Lt, Rt : Integerπ end;ππ SortStak = Array [0..1] of SortRec;ππVarπ StkT,π StkM,π Ki, Kj,π M : Word;π Rt, Lt,π I, J : Integer;π Ps : ^SortStak;π Pw, Px : Pointer;ππ Procedure Push(Left, Right : Integer);π beginπ Ps^[StkT].Lt := Left;π Ps^[StkT].Rt := Right;π Inc(StkT);π end;ππ Procedure Pop(Var Left, Right : Integer);π beginπ Dec(StkT);π Left := Ps^[StkT].Lt;π Right := Ps^[StkT].Rt;π end;ππbegin {QSort}π if (Cnt > 1) and (V <> Nil) Thenπ beginπ StkT := Cnt - 1; { Record Count - 1 }π Lt := 1; { Safety Valve }ππ { We need a stack of Log2(n-1) entries plus 1 spare For safety }ππ Repeatπ StkT := StkT SHR 1;π Inc(Lt);π Until StkT = 0; { 1+Log2(n-1) }ππ StkM := Lt * SizeOf(SortRec) + Len + Len; { Stack Size + 2 Records }ππ GetMem(Ps, StkM); { Allocate Memory }ππ if Ps = Nil Thenπ RunError(215); { Catastrophic Error }ππ Pw := @Ps^[Lt]; { Swap Area Pointer }π Px := Ptr(Seg(Pw^), Ofs(Pw^) + Len); { Hold Area Pointer }ππ Lt := 0;π Rt := Cnt - 1; { Initial Partition }ππ Push(Lt, Rt); { Push Entire Table }ππ While StkT > 0 Doπ begin { QuickSort Main Loop }π Pop(Lt, Rt); { Get Next Partition }π Repeatπ I := Lt; J := Rt; { Set Work Pointers }ππ { Save Record at Partition Mid-Point in Hold Area }π M := (LongInt(Lt) + Rt) div 2;π Move(Ptr(Seg(V^), Ofs(V^) + M * Len)^, Px^, Len);ππ { Get Useful Offsets to speed loops }π Ki := I * Len + Ofs(V^);π Kj := J * Len + Ofs(V^);ππ Repeatπ { Find Left-Most Entry >= Mid-Point Entry }π While ALessB(Ptr(Seg(V^), Ki)^, Px^) Doπ beginπ Inc(Ki, Len);π Inc(I)π end;ππ { Find Right-Most Entry <= Mid-Point Entry }π While ALessB(Px^, Ptr(Seg(V^), Kj)^) Doπ beginπ Dec(Kj, Len);π Dec(J)π end;ππ { if I > J, the partition has been exhausted }π if I <= J Thenπ beginπ if I < J Then { we have two Records to exchange }π beginπ Move(Ptr(Seg(V^), Ki)^, Pw^, Len);π Move(Ptr(Seg(V^), Kj)^, Ptr(Seg(V^), Ki)^, Len);π Move(Pw^, Ptr(Seg(V^), Kj)^, Len);π end;ππ Inc(I);π Dec(J);π Inc(Ki, Len);π Dec(Kj, Len);π end; { if I <= J }π Until I > J; { Until All Swaps Done }ππ { We now have two partitions. At left are all Records }π { < X, and at right are all Records > X. The larger }π { partition is stacked and we re-partition the residue }π { Until time to pop a deferred partition. }ππ if (J - Lt) < (Rt - I) Then { Right-Most Partition is Larger }π beginπ if I < Rt Thenπ Push(I, Rt); { Stack Right Side }π Rt := J; { Resume With Left }π endπ else { Left-Most Partition is Larger }π beginπ if Lt < J Thenπ Push(Lt, J); { Stack Left Side }π Lt := I; { Resume With Right }π end;ππ Until Lt >= Rt; { QuickSort is now Complete }π end;π FreeMem(Ps, StkM); { Free Stack and Work Areas }π end;πend; {QSort}π 35 08-27-9321:48ALL ALEXANDER CHRISTOV QSort Methods IMPORT 82 S {πALEXANDER CHRISTOVππ I don't know if code like this has been posted on this echo, but anyway hereπit goes. It implements three different versions of Qsort which so far if theπfastest sorting algorithm known. However, it is not adequate For sorting FileπRecords. I've tested the routines and have worked With them For quite a While,πbut don't trust me 8-) Murphy never sleeps 8-)π}ππUnit SORT;π{─────────────────────────────────────────────────────────────────────────}π{ Purpose : Unit that implements a generic QSort(), similar to }π{ the one in the standard C library. }π{ Author : Alexander Christov }π{ Notes : Very instructive on the use of Pointers in TP. }π{ }π{ Use freely. }π{ }π{─────────────────────────────────────────────────────────────────────────}πInterfaceππType CmpFunc=Function(El1,El2:Pointer):Boolean;ππProcedure QSort(Base:Pointer;Elements,Size:Word;GT:CmpFunc);ππ{ Base - Pointer to the first elementπ Elements - Number of elementsπ Size - Size of an element in Bytes. Use SizeOf() if in doubtπ GT - A Function of Type CmpFunc that compares the elements pointedπ to by the first and the second arguments and returns Trueπ if the first is greater than the second. GT = Greater Thanπ 8-)π}ππ{ Some commonly used CmpFunc }ππFunction bGT(El1,El2:Pointer):Boolean; { Compares ^Byte }πFunction wGT(El1,El2:Pointer):Boolean; { Compares ^Word }πFunction lGT(El1,El2:Pointer):Boolean; { Compares ^LongInt }πFunction rGT(El1,El2:Pointer):Boolean; { Compares ^Real }ππImplementationπ{$F+}ππType Dummy=Array[0..0] of Byte;π pDummy=^Dummy;πππ{ Recursive Implementation }ππProcedure _Sort(Base:Pointer;L,R,Size:Word;GT:CmpFunc);πVar I,J:Integer;πVar X:Pointer;π Procedure SwapElements(El1,El2:Word);π Var Tmp:Pointer;π beginπ GetMem(Tmp,Size);π Move(pDummy(Base)^[El1*Size],Tmp^,Size);π Move(pDummy(Base)^[El2*Size],pDummy(Base)^[El1*Size],Size);π Move(Tmp^,pDummy(Base)^[El2*Size],Size);π FreeMem(Tmp,Size);π end;πbeginπ I:=L;π J:=R;π GetMem(X,Size);π Move(pDummy(Base)^[((L+R) div 2)*Size],X^,Size);π Repeatπ While GT(X,@pDummy(Base)^[I*Size]) do INC(I);π While GT(@pDummy(Base)^[J*Size],X) do DEC(J);π if I<=J then beginπ if I<>J then SwapElements(I,J);π INC(I);π DEC(J);π end;π Until I>J;π FreeMem(X,Size);π if L<J then _Sort(Base,L,J,Size,GT);π if I<R then _Sort(Base,I,R,Size,GT);πend;ππProcedure QSort(Base:Pointer;Elements,Size:Word;GT:CmpFunc);πbeginπ _Sort(Base,0,Elements-1,Size,GT);πend;ππFunction bGT(El1,El2:Pointer):Boolean;πType pByte=^Byte;πbeginπ bGt:=(pByte(El1)^>pByte(El2)^);πend;ππFunction wGT(El1,El2:Pointer):Boolean;πType pWord=^Word;πbeginπ wGt:=(pWord(El1)^>pWord(El2)^);πend;ππFunction lGT(El1,El2:Pointer):Boolean;πType pLongInt=^LongInt;πbeginπ lGt:=(pLongInt(El1)^>pLongInt(El2)^);πend;ππFunction rGT(El1,El2:Pointer):Boolean;πType pReal=^Real;πbeginπ rGt:=(pReal(El1)^>pReal(El2)^);πend;ππend.ππππ{$A-,B-,D+,E-,F+,G+,I-,L+,N-,O+,P+,Q-,R-,S-,T-,V-,X+,Y+}π{ I don't know which settings are Really necessary For this Unit, but sinceπ I always work With the above, I'm including them to make sure the Unitπ compiles in your computer. The only critical ones (I Think) are R- and F+π}πUnit SORT;π{─────────────────────────────────────────────────────────────────────────}π{ Purpose: Unit that implements a generic QSort, similar to the }π{ one in the standard C library, but a lot more general }π{ This new version allows ordering of almost anything, }π{ even structures whose elements are not contiguous in memory }π{ or have strange mutual dependancies that don't allow "happy }π{ swapping". Obviously, this version is slower than the }π{ previous one. if you won't be sorting Linked Lists or }π{ Collections, use the previous one. }π{ Author : Alexander Christov }π{ Notes : Very instructive on the use of Pointers in TP. }π{ This version does not limit the number of elements to }π{ 65535 since the need not be contiguous. }π{ }π{ Use freely. }π{ }π{─────────────────────────────────────────────────────────────────────────}πInterfaceππType CmpFunc=Function(El1,El2:Pointer):Boolean;π AddrFunc=Function(Base:Pointer;Size,N:LongInt):Pointer;π SwapProc=Procedure(El1,El2:Pointer;Size:LongInt);ππProcedure QSort(Base:Pointer; { Pointer to the first element.π if the user Writes his own GT, Addr andπ Swap, this isn't Really necessary.π }π Elements:LongInt; { Total number of elements }π Size:Word; { Size of an element in Bytes }π GT:CmpFunc; { Comparing Function }π Addr:AddrFunc; { Addressing Function }π Swap:SwapProc); { Swapping Function }ππ{π GT - A funcion of Type CmpFunc that compares the elements pointedπ to by its first and second arguments, and returns True if theπ first element is Greater Than the second one. This Unit definesπ some commonly used CmpFuncs:π bGT - Compares Bytesπ wGT - Compares Wordsπ lGT - Compares LongIntsπ rGT - Compares Realsππ Addr - A Function that receives the index of an element and mustπ return a Pointer to it.π This Unit defines the Functionπ LinearAddrπ which can be used whenever the elements are locatedπ contiguously in memory.ππ Swap - A Procedure that swaps the elements pointed by its arguments.π DirectSwapπ is defined in the Unit, which can be used whenever the elementsπ are mutually independent or no external processes are neededπ when swapping two elementsπ}ππ{ Commonly used CmpFuncs }ππFunction bGT(El1,El2:Pointer):Boolean; { Compares ^Byte }πFunction wGT(El1,El2:Pointer):Boolean; { Compares ^Word }πFunction lGT(El1,El2:Pointer):Boolean; { Compares ^LongInt }πFunction rGT(El1,El2:Pointer):Boolean; { Compares ^Real }ππFunction LinearAddr(Base:Pointer;Size,N:LongInt):Pointer;πProcedure DirectSwap(El1,El2:Pointer;Size:LongInt);ππImplementationπ{$F+}ππType Dummy=Array[0..0] of Byte;π pDummy=^Dummy;πππVar X,Middle:Pointer;ππProcedureπ_Sort(Base:Pointer;L,R:LongInt;Size:Word;GT:CmpFunc;Addr:AddrFunc;Swap:SwapProcπ);πVar I,J:LongInt;πbeginπ I:=L;π J:=R;π Move(Addr(Base,Size,(L+R) div 2)^,Middle^,Size);π Repeatπ While GT(Middle,Addr(Base,Size,I)) do INC(I);π While GT(Addr(Base,Size,J),Middle) do DEC(J);π if I<=J then beginπ if I<>J then Swap(Addr(Base,Size,I),Addr(Base,Size,J),Size);π INC(I);π DEC(J);π end;π Until I>J;π if L<J then _Sort(Base,L,J,Size,GT,Addr,Swap);π if I<R then _Sort(Base,I,R,Size,GT,Addr,Swap);πend;ππProcedure QSort;πbeginπ GetMem(X,Size); { <- Made in Arturo Ramirez 8-) }π GetMem(Middle,Size);π _Sort(Base,0,Elements-1,Size,GT,Addr,Swap);π FreeMem(X,Size);π FreeMem(Middle,Size);πend;ππFunction bGT(El1,El2:Pointer):Boolean;πType pByte=^Byte;πbeginπ bGt:=(pByte(El1)^>pByte(El2)^);πend;ππFunction wGT(El1,El2:Pointer):Boolean;πType pWord=^Word;πbeginπ wGt:=(pWord(El1)^>pWord(El2)^);πend;ππFunction lGT(El1,El2:Pointer):Boolean;πType pLongInt=^LongInt;πbeginπ lGt:=(pLongInt(El1)^>pLongInt(El2)^);πend;ππFunction rGT(El1,El2:Pointer):Boolean;πType pReal=^Real;πbeginπ rGt:=(pReal(El1)^>pReal(El2)^);πend;ππ{ Linear Addressing }ππFunction LinearAddr;πbeginπ LinearAddr:=@pdummy(Base)^[N*Size];πend;ππ{ Direct swapping of elements. With the use of Addr() it is quite moreπ legible 8-) }ππProcedure DirectSwap;πVar Tmp:Pointer;πbeginπ GetMem(Tmp,Size);π Move(El1^,Tmp^,Size);π Move(El2^,El1^,Size);π Move(Tmp^,El2^,Size);π FreeMem(Tmp,Size);πend;ππend.πππ{ And finally a specific version of QSort() written in Assembler. It isπ non recursive and sorts Arrays of Words of up to 16383 elements (sinceπ it Uses the addresses of the elements rather than their indexes, and sinceπ SizeOf(Word)=2 -> 16384*2=32768 "=" -32768, and the routine Uses signedπ comparisons between adresses.π On my 386/33 it sorts 10 times an Array of 10000 Words in 3.6 sec, Whileπ the first QSort() does the same in 46 sec.ππ Must be called Withππ Qsort(Pointer to the first element, 0, elements-1)ππ Use freely. if you include the source directly in your Program, creditπ must be given.π}ππProcedure QSort(Base:Pointer;L,R:Word);Assembler;πVar TmpL,TmpR,TmpDI:Word;πAsmπ xor AX,AXπ PUSH AXπ PUSH AX { 0 0 will act as a flag on the stack indicating that no more }π PUSH R { (L,R) pairs need to be sorted }π PUSH Lπ@MainLoop:π LES DI,Baseπ MOV TmpDI,DIπ xor SI,SIπ MOV BX,DIπ POP AX { AX<-L }π MOV TmpL,AXπ MOV SI,AXπ SHL AX,1π ADD DI,AXπ POP AX { AX<-R }π MOV TmpR,AXπ and AX,AX { R can be never 0 except if this is the (0,0) flag }π JZ @endπ ADD SI,AXπ SHL AX,1π ADD BX,AXπ and SI,$FFFEπ ADD SI,TmpDIππ { ES:DI -> Element[I] (L)π ES:BX -> Element[J] (R)π ES:SI -> Element[(L+R) div 2]π }ππ MOV AX,ES:[SI]π@Loop1:π MOV CX,ES:[DI]π CMP AX,CXπ JNA @Loop2π ADD DI,2π JMP @Loop1π@Loop2:π MOV CX,ES:[BX]π CMP CX,AXπ JNA @Checkπ SUB BX,2π JMP @Loop2π@Check:π CMP DI,BXπ JG @Cont1π MOV CX,ES:[DI]π MOV DX,ES:[BX]π MOV ES:[DI],DXπ MOV ES:[BX],CXπ ADD DI,2π SUB BX,2π CMP DI,BXπ JNG @Loop1ππ@Cont1:π SUB DI,TmpDIπ SAR DI,1 { DI - I }π SUB BX,TmpDIπ SAR BX,1 { BX - J }π CMP DI,TmpRπ JGE @Cont2π PUSH TmpR { I<R }π PUSH DIπ@Cont2:π CMP TmpL,BXπ JGE @MainLoopπ PUSH BX { L<J }π PUSH TmpLπ JMP @MainLoopππ@end:πend;ππ 36 08-27-9321:58ALL MATT HARGETT Shell Sorting IMPORT 7 S {πMATT HARGETTππ: want to use the normal ole' bubble sorts and the like (on the order of N),π: for the mere fact that it's just plain old slow! Could anyone please postπ: some code, or pseudo-code of a sort that is on the order of NxLog N? It woπ}ππProgram ShellSort;ππVarπ A : Array [1..1000] of Word;π I, J, N,π K, Tmp : Integer;ππBeginπ N := 1000;π For I := 1 to N Doπ Beginπ A[I] := Random(5000) + 1;π Write(A[I] : 6);π End;ππ For K := 3 DownTo 1 Doπ For I := 1 to N - 1 Doπ For J := I + 1 to N Doπ If A[J] < A[I]π thenπ Beginπ Tmp := A[J];π A[J] := A[I];π A[I] := Tmp;π End;ππ Writeln;ππ For I := 1 To N Doπ Write(A[I] : 6);πEnd.ππ 37 11-21-9309:46ALL BOB SWART QUICK SORTER SWAG9311 20 S {πFrom: BOB SWARTπSubj: Sorting...π---------------------------------------------------------------------------π Does anyone know of a VERY fast way to sort something? I wouldπ really like to view some source code on this if possible. I need toπ sort over 1200 strings, and do it rather quickly.ππ Try this, it uses a TStringCollection...π}ππ{$IFDEF VER70}π{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,Q-,R-,S+,T-,V-,X-}π{$ELSE}π{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S+,V-,X-}π{$ENDIF}π{$M 16384,0,655360}π{π Sorteer 3.0π Borland Pascal (Objects) 7.0.π Copr. (c) 9-29-1993 DwarFools & Consultancy drs. Robert E. Swartπ P.O. box 799π 5702 NP Helmondπ The Netherlandsπ Code size: 5824 Bytesπ Data size: 1254 Bytesπ .EXE size: 4971 Bytesπ ----------------------------------------------------------------π Authors: Bob Swart (2:281/256.12)π Hans van der Veeke (2:282/517.2)π}πuses {$IFDEF WINDOWS}π WinCrt,π {$ENDIF}π Objects;ππTypeπ PStr = ^TStr;π TStr = object(TObject)π StrName: PString;π constructor Init(_StrName: String);π end {TStr};ππ constructor TStr.Init(_StrName: String);π beginπ TObject.Init;π StrName := NewStr(_StrName)π end {Init};ππTypeπ PStrColl = ^TStrColl;π TStrColl = object(TStringCollection)π function KeyOf(Item: Pointer): Pointer; virtual;π end {TStrColl};ππ function TStrColl.KeyOf(Item: Pointer): Pointer;π beginπ KeyOf := PStr(Item)^.StrNameπ end {KeyOf};ππvar StrColl: PStrColl;π Line: String;π F: Text;πbeginπ writeln('Sorteer - Sort strings (c) 1993 by Bob Swart & Hans van der Veeke.'#13#10);π if ParamCount = 0 thenπ beginπ writeln('Usage: Sorteer [ASCII file to be sorted]');π Halt(0)π end;π Assign(F,ParamStr(1));π reset(F);π if IOResult <> 0 thenπ beginπ writeln('Error - could not open file ',ParamStr(1));π Halt(1)π end;π StrColl := New(PStrColl,Init(1000,500));π StrColl^.Duplicates := True; { make False for NO duplicates }π while not Eof(F) doπ beginπ readln(F,Line);π if Length(Line) > 0 then StrColl^.Insert(New(PStr, Init(Line)))π end;π Close(F);π while StrColl^.Count > 0 doπ beginπ writeln(PStr(StrColl^.At(0))^.StrName^); { print first element }π StrColl^.AtFree(0); { delete and dispose first element StrColl }π endπend.π 38 11-02-9306:21ALL IAN LIN Linked list sort SWAG9311 29 S (*πIAN LINππ> Can someone show me an example of how to properly dispose of a linked list?ππI was just as bad when I started in February. :) Anyhow, use mark andπrelease. They're 2 new things I've discovered and love much more thanπdispose or freemem. Use MARK(ram) where VAR RAM:POINTER {an untypedπpointer}. This will save the state of the heap. NOW, when you are done,πdo this: release(ram) and it's back the way it was. No freemem, no dispose,πjust RELEASE! I REALLY love it. :) Need to allocate and deallocate someπtimes in between the beginning and the end? Use more untyped pointers (eg.πRAM2, RAM3, etc.) and you get the picture. Gotta love it. :) Look for aπmessage from me in here about linked list sorting. I wrote an entireπprogram that does this (to replace DOS's sort. Mine's faster and can useπmore than 64k RAM). Here it is. Some of it is maybe too hard for you butπthen you can ignore that part and just see how I used mark and release.π*)ππ{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S-,V-,X-}π{$M 8192, 0, 655360}ππtypeπ pstring = ^string;π prec = ^rec;ππ rec = recordπ s : pstring;π n : prec;π end;ππVarπ dash : byte;π err,π max, c : word;π list,π list2,π node,π node2 : prec;π ram,π ram2,π ram3 : pointer;π tf : text;π f : file;ππprocedure dodash;πbeginπ case dash ofπ 1 : write('-');π 2 : write('\');π 3 : write('|');π 4 : write('/');π end;π write(#8, ' ', #8);π dash := dash mod 4 + 1;πend;ππprocedure TheEnd;πbeginπ writeln('Assassin Technologies, NetRunner.');π halt(err);πend;ππprocedure showhelp;πbeginπ writeln('Heavy duty sorter. Syntax: NSORT <INFILE> <OUTFILE>.');π writeln('Exit codes: 0-normal; 1-not enough RAM; 2-can''t open infile;');π writeln('3-outfile can''t be created');π halt;πend;ππprocedure noram;πbeginπ release(ram);π assign(f, paramstr(1));π writeln('Not enough RAM. ', memavail div 1024, 'k; file: ', filesize(f));π err := 1;π halt;πend;ππprocedure newnode(var pntr : prec);πbeginπ if sizeof(prec) > maxavail thenπ beginπ close(tf);π noram;π end;π new(pntr);π dodash;π pntr^.n := nil;πend;ππprocedure getln(var ln : pstring);πvarπ line : string;π size : word;πbeginπ readln(tf, line);π size := succ(length(line));π if size > maxavail thenπ noram;π getmem(ln, size);π move(line, ln^, succ(length(line)));π dodash;πend;ππbeginπ err := 0;π exitproc := @TheEnd;π if paramcount = 0 thenπ showhelp;π assign(tf, paramstr(1));π reset(tf);ππ if ioresult <> 0 thenπ beginπ writeln('Can''t open "', paramstr(1), '".');π err := 2;π halt;π end;ππ mark(ram);π newnode(list);ππ if not eof(tf) thenπ beginπ getln(list^.s);π node := list;ππ while not eof(tf) doπ beginπ newnode(node^.n);π node := node^.n;π getln(node^.s);π end;ππ close(tf);π newnode(list2);π list2^.n := list;π list := list^.n;π list2^.n^.n := nil;ππ while list <> nil doπ beginπ dodash;π node := list;π list := list^.n;π node2 := list2;ππ while (node2^.n <> nil) and (node^.s^ > node2^.n^.s^) doπ node2 := node2^.n;ππ node^.n := node2^.n;π node2^.n := node;π dodash;π end;π list := list2^.n;ππ assign(tf, paramstr(2));π rewrite(tf);π if ioresult <> 0 thenπ beginπ writeln('Can''t create "', paramstr(2), '"');π err := 3;π end;ππ node := list;π while node <> nil doπ beginπ writeln(tf, node^.s^);π node := node^.n;π dodash;π end;π writeln;π close(tf);π release(ram);π end;πend.π 39 11-02-9306:22ALL IAN LIN Quick Sort using LINK SWAG9311 21 S {πIAN LINππMy pride and joy, this baby sorts FAST! This is For anyone who wants anπexample of code For sorting linked lists.π}ππ{$A+,B-,D+,E-,F-,G+,I-,L+,N-,O-,R-,S+,V-,X-}π{$M 4096,0,655360}ππProcedure Theend; {could you think of a better name???}πbeginπ Writeln('Assassin Technologies, NetRunner.');π {members: Ian Lin, Martin Young, William Parslow, Scott Rogers; just a newπ Programming group, that's all.}π halt; {duh, kinda obvious you need to end the Program. :) }πend;ππTypeπ prec = ^rec;π dType = String[96]; {put what you want here, it's fast anyhow}π rec = Recordπ d : dType;π n : prec; {"next" field"}π end;ππVarπ max, c : Word; {maximum # of elements; Counter}π list,π list2,π node,π node2 : prec; {first and second lists, temporary Pointers to nodes in the lists}π ram : Pointer; {save heap state For use With mark/release}ππbeginπ max := memavail div sizeof(dType); {this takes too long but is THE maximum}π max := 675; {I picked this at random--it sorts in 2 seconds or so}π Exitproc := @Theend; {just to be fancy}π randomize;π mark(ram);π new(list); {create list}π list^.d := Char(random(10) + 48); {put something in it}π node := list;π For c := 2 to max doπ beginπ new(node^.n);π node := node^.n;π node^.n := nil;π node^.d := Char(random(10) + 48);π end;ππ new(list2); {begin NEW sorted list}π list2^.n := list; {steal the first node of list For list2}π list := list^.n;π list2^.n^.n := nil;π While list <> nil doπ begin {now steal 'em all and add them in order}π node := list; {point node to first node in LIST}π list := list^.n; {advance LIST Pointer one node, first node is now seperate}π node2 := list2; {ready to use NODE2 to find the correct entry point}π While (node2^.n <> nil) and (node^.d > node2^.n^.d) doπ node2 := node2^.n; {advance NODE2 as needed Until it marks theπ right place For NODE to be inserted}π node^.n := node2^.n;{insert NODE into the new list, in the correct order}π node2^.n := node; {connect node to the previous nodes in new list, if any}π end;π list := list2^.n; {point LIST back to the top of the list, now in order}ππ node := list; {the rest is just to display it}π Write('List: ');π While node <> nil doπ begin {as usual (at least With me), NIL is the end}π Write(node^.d);π node := node^.n;π end;π Writeln;π release(ram); {give all heap RAM back}πend.π 40 09-26-9310:15ALL ROLAND WODITSCH Classic QSORT Routine SWAG9311 30 S (*πFrom: ROLAND WODITSCHπSubj: QUICK SORTπ*)ππUNIT QSort5;ππINTERFACEπTYPE OrdFunction = FUNCTION(VAR a,b):BOOLEAN;ππPROCEDURE Sortiere(VAR SortArray; Elementgroesse,LoIndex,HiIndex: word;π SortKleiner: OrdFunction; von,bis:word);ππ{ SortArray field to sort }π{ LoIndex the lowest, }π{ HiIndex the highest fieldindex like in the fielddeklarartion }π{ OrdAdr the funktion from typ OrdFunction (s.o.) }π{ von, bis the sortarea }ππ{ befor calling (not befor bind!) your have to define a }π{ asymmetric order funktion : }π{ function IrgendEinName(VAR x,y : TypDerFeldElemente):boolean }π{ example: (*$F+*) function kleiner(VAR x,y: integer):boolean; }π{ begin kleiner:=x<y end; (*$F-*) }π{ not: kleiner:=x<=y (not asymmetric!) }π{ attention: x and y must be VAR-parameters !!! }ππππIMPLEMENTATIONππprocedure Sortiere(VAR SortArray; ElementGroesse,LoIndex,HiIndex: word;π SortKleiner:OrdFunction; von,bis:word);π type ArrayPtr = ^Byte;π var Mitte, i0, j0, m0 : ArrayPtr;ππ procedure Swap(VAR x,y; size : word);π beginπ INLINE ($1E/$C4/$B6/X/$C5/$BE/Y/$8B/$8E/SIZE/$E3/$0C/$26/$8A/$04/π $86/$05/$26/$88/$04/$46/$47/$E2/$F4/$1F)π end;ππ function Element(i : word) : ArrayPtr;π beginπ Element:=ptr(seg(SortArray),ofs(SortArray)+i*ElementGroesse)π end;ππ procedure inc(var index : word; var pointer : ArrayPtr);π beginπ index:=succ(index);π pointer:=ptr(seg(pointer^),ofs(pointer^)+ElementGroesse)π end;ππ procedure dec(var index : word; var pointer : ArrayPtr);π beginπ index:=pred(index);π pointer:=ptr(seg(pointer^),ofs(pointer^)-ElementGroesse)π end;ππ procedure E_Sort(von, bis : word);π label EXIT;π var i, j : word;π beginπ if bis<=von then goto EXIT;π i:=von; i0:=Element(i);π while i<bis do beginπ m0:=i0; j:=i; j0:=i0; inc(j,j0);π while j<=bis do beginπ if SortKleiner(j0^,m0^) then m0:=j0;π inc(j,j0)π end; (* WHILE j *)π if m0<>i0 then Swap(i0^,m0^,ElementGroesse);π inc(i,i0)π end; (* WHILE i *)π EXIT:π end; (* E_Sort *)ππ procedure Sort(von, bis : word); (* Rekursive Quicksort *)π label EXIT;π var i, j : word;π beginπ if bis-von<6 then begin E_Sort(von,bis); goto EXIT end;π i:=von; j:=bis; m0:=Element((i+j) SHR 1);π move(m0^,Mitte^,ElementGroesse); i0:=Element(i); j0:=Element(j);π while i<=j do beginπ while SortKleiner(i0^,Mitte^) do inc(i,i0);π while SortKleiner(Mitte^,j0^) do dec(j,j0);π if i<=j then beginπ if i<>j then Swap(i0^,j0^,ElementGroesse);π inc(i,i0); dec(j,j0)π end (* if i<=j *)π end; (* while i<=j *)π if bis-i<j-von then beginπ if i<bis then Sort(i,bis);π if von<j then Sort(von,j)π endπ else beginπ if von<j then Sort(von,j);π if i<bis then Sort(i,bis)π end;π EXIT:π end; (* Sort *)ππ beginπ getmem(Mitte,ElementGroesse);π Sort(von-LoIndex,bis-LoIndex);π freemem(Mitte,ElementGroesse)π end; (* Sort *)ππEND. (* IMPLEMENTATION OF UNIT QSORT *)ππ 41 11-26-9317:46ALL SWAG SUPPORT GROUP Complete Sorting Unit SWAG9311 53 S UNIT Sort;ππ { These sort routines are for arrays of Integers. Count is the maximum }π { number of items in the array. }ππ{****************************************************************************}π INTERFACEπ{****************************************************************************}πFUNCTION BinarySearch (VAR A; X : Integer; Count : Integer) : Integer;πPROCEDURE BubbleSort (VAR A; Count : Integer); {slow}πPROCEDURE CombSort (VAR A; Count : Integer);πPROCEDURE QuickSort (VAR A; Count : Integer); {fast}πFUNCTION SequentialSearch (VAR A; X : Integer; Count : Integer) : Integer;πPROCEDURE ShellSort (VAR A; Count : Integer); {moderate}π{****************************************************************************}π IMPLEMENTATIONπ{****************************************************************************}πTYPEπ SortArray = ARRAY[0..0] OF Integer;π{****************************************************************************}π{ }π{ Local Procedures and Functions }π{ }π{****************************************************************************}πPROCEDURE Swap (VAR A, B : Integer);πVAR C : Integer;πBEGINπ C := A;π A := B;π B := C;πEND;π{****************************************************************************}π{ }π{ Global Procedures and Functions }π{ }π{****************************************************************************}πFUNCTION BinarySearch (VAR A; X : Integer; Count : Integer) : Integer;πVAR High, Low, Mid : Integer;πBEGINπ Low := 1;π High := Count;π WHILE High >= Low DOπ BEGINπ Mid := Trunc(High + Low) DIV 2;π IF X > SortArray(A)[mid]π THEN Low := Mid + 1π ELSE IF X < SortArray(A)[Mid]π THEN High := Mid - 1π ELSE High := -1;π END;π IF High = -1π THEN BinarySearch := Midπ ELSE BinarySearch := 0;π END;π{****************************************************************************}πPROCEDURE BubbleSort (VAR A; Count : Integer);πVAR i, j : Integer;πBEGINπ FOR i := 2 TO Count DOπ FOR j := Count DOWNTO i DOπ IF SortArray(A)[j-1] > SortArray(A)[j]π THEN Swap(SortArray(A)[j],SortArray(A)[j-1]);πEND;π{****************************************************************************}πPROCEDURE CombSort (VAR A; Count : Integer);π { The combsort is an optimised version of the bubble sort. It uses a }π { decreasing gap in order to compare values of more than one element }π { apart. By decreasing the gap the array is gradually "combed" into }π { order ... like combing your hair. First you get rid of the large }π { tangles, then the smaller ones ... }π { There are a few particular things about the combsort. }π { Firstly, the optimal shrink factor is 1.3 (worked out through a }π { process of exhaustion by the guys at BYTE magazine). Secondly, by }π { never having a gap of 9 or 10, but always using 11, the sort is }π { faster. }π { This sort approximates an n log n sort - it's faster than any other }π { sort I've seen except the quicksort (and it beats that too sometimes). }π { The combsort does not slow down under *any* circumstances. In fact, on }π { partially sorted lists (including *reverse* sorted lists) it speeds up.}πCONST ShrinkFactor = 1.3; { Optimal shrink factor ... }πVARπ Gap, i, Temp : Integer;π Finished : Boolean;πBEGINπ Gap := Trunc(ShrinkFactor);π REPEATπ Finished := TRUE;π Gap := Trunc(Gap/ShrinkFactor);π IF Gap < 1π THEN { Gap must *never* be less than 1 } Gap := 1π ELSE IF Gap IN [9,10]π THEN { Optimises the sort ... } Gap := 11;π FOR i := 1 TO (Count - Gap) DOπ IF SortArray(A)[i] < SortArray(A)[i+gap]π THEN BEGINπ Swap(SortArray(A)[i],SortArray(A)[i + Gap]);π Finished := FALSE;π END;π UNTIL (Gap = 1) AND Finished;πEND;π{****************************************************************************}πPROCEDURE QuickSort (VAR A; Count : Integer);π {**************************************************************************}π PROCEDURE PartialSort(LowerBoundary, UpperBoundary : Integer; VAR A);π VAR ii, l1, r1, i, j, k : Integer;π BEGINπ k := (SortArray(A)[LowerBoundary] + SortArray(A)[UpperBoundary]) DIV 2;π i := LowerBoundary;π j := UpperBoundary;π REPEATπ WHILE SortArray(A)[i] < k DO Inc(i);π WHILE k < SortArray(A)[j] DO Dec(j);π IF i <= jπ THEN BEGINπ Swap(SortArray(A)[i],SortArray(A)[j]);π Inc(i);π Dec(j);π END;π UNTIL i > j;π IF LowerBoundary < jπ THEN PartialSort(LowerBoundary,j,A);π IF i < UpperBoundaryπ THEN PartialSort(UpperBoundary,i,A);π END;π {*************************************************************************}πBEGINπ PartialSort(1,Count,A);πEND;π{****************************************************************************}πFUNCTION SequentialSearch (VAR A; X : Integer; Count : Integer) : Integer;πVAR i : Integer;πBEGINπ FOR i := 1 TO Count DOπ IF X = Sortarray(A)[i]π THEN BEGINπ SequentialSearch := i;π Exit;π END;π SequentialSearch := 0;πEND;π{****************************************************************************}πPROCEDURE ShellSort (VAR A; Count : Integer);πVAR Gap, i, j, k : Integer;πBEGINπ Gap := Count DIV 2;π WHILE (gap > 0) DOπ BEGINπ FOR i := (Gap + 1) TO Count DOπ BEGINπ j := i - Gap;π WHILE (j > 0) DOπ BEGINπ k := j + gap;π IF (SortArray(A)[j] <= SortArray(A)[k])π THEN j := 0π ELSE Swap(SortArray(A)[j],SortArray(A)[k]);π j := j - Gap;π END;π END;π Gap := Gap DIV 2;π END;πEND;π{*****************************************************************************}πEND.π 42 11-26-9317:00ALL SWAG SUPPORT TEAM Full featured Sort Unit SWAG9311 83 S Unit SORTER;ππINTERFACEππTYPEπ PtrArray = ARRAY[1..1] OF Pointer;ππ TCompareFunction = FUNCTION (VAR AnArray; Item1, Item2 : LongInt) : Integer;π { A TCompareFunction must return: }π { 1 if the Item1 > Item2 }π { 0 if the Item1 = Item2 }π { -1 if the Item1 < Item2 }ππ TSwapProcedure = PROCEDURE (VAR AnArray; Item1, Item2 : LongInt);πππPROCEDURE CombSort (VAR AnArray; Min, Max : LongInt;π Compare : TCompareFunction; Swap : TSwapProcedure);ππ { Compare Procedures - Must write your own Compare for pointer variables. }π { This allows one sort routine to be used on any array. }πFUNCTION CompareChars (VAR AnArray; Item1, Item2 : LongInt) : Integer;π FAR;πFUNCTION CompareInts (VAR AnArray; Item1, Item2 : LongInt) : Integer;π FAR;πFUNCTION CompareLongInts (VAR AnArray; Item1, Item2 : LongInt) : Integer;π FAR;πFUNCTION CompareReals (VAR AnArray; Item1, Item2 : LongInt) : Integer;π FAR;πFUNCTION CompareStrs (VAR AnArray; Item1, Item2 : LongInt) : Integer;π FAR;ππ { Swap procedures to be used in any sorting routine. }π { This allows one sorting routine to be on any array. }πPROCEDURE SwapChars (VAR AnArray; A, B : LongInt); FAR;πPROCEDURE SwapInts (VAR AnArray; A, B : LongInt); FAR;πPROCEDURE SwapLongInts (VAR AnArray; A, B : LongInt); FAR;πPROCEDURE SwapPtrs (VAR AnArray; A, B : LongInt); FAR;πPROCEDURE SwapReals (VAR AnArray; A, B : LongInt); FAR;πPROCEDURE SwapStrs (VAR AnArray; A, B : LongInt); FAR;π{****************************************************************************}π IMPLEMENTATIONπ{****************************************************************************}πTYPEπ CharArray = ARRAY[1..1] OF Char;π IntArray = ARRAY[1..1] OF Integer;π LongIntArray = ARRAY[1..1] OF LongInt;π RealArray = ARRAY[1..1] OF Real;π StrArray = ARRAY[1..1] OF String;ππ{****************************************************************************}π{ }π{ Local Procedures and Functions }π{ }π{****************************************************************************}πPROCEDURE AdjustArrayIndexes (VAR Min, Max : LongInt);π { Adjusts array indexes to a one-based array. }πVAR Fudge : LongInt;πBEGINπ Fudge := 1 - Min;π Inc(Min,Fudge);π Inc(Max,Fudge);πEND;π{****************************************************************************}π{ }π{ Global Procedures and Functions }π{ }π{****************************************************************************π}PROCEDURE CombSort (VAR AnArray; Min, Max : LongInt;π Compare : TCompareFunction; Swap : TSwapProcedure);π { The combsort is an optimised version of the bubble sort. It uses a }π { decreasing gap in order to compare values of more than one element }π { apart. By decreasing the gap the array is gradually "combed" into }π { order ... like combing your hair. First you get rid of the large }π { tangles, then the smaller ones ... }π { }π { There are a few particular things about the combsort. Firstly, the }π { optimal shrink factor is 1.3 (worked out through a process of }π { exhaustion by the guys at BYTE magazine). Secondly, by never }π { having a gap of 9 or 10, but always using 11, the sort is faster. }π { }π { This sort approximates an n log n sort - it's faster than any }π { other sort I've seen except the quicksort (and it beats that too }π { sometimes ... have you ever seen a quicksort become an (n-1)^2 }π { sort ... ?). The combsort does not slow down under *any* }π { circumstances. In fact, on partially sorted lists (including }π { *reverse* sorted lists) it speeds up. }π { }π { More information in the April 1991 BYTE magazine. }πCONST ShrinkFactor = 1.3;πVAR Gap, i : LongInt;π Finished : Boolean;πBEGINπ AdjustArrayIndexes(Min,Max);π Gap := Round(Max/ShrinkFactor);π REPEATπ Finished := TRUE;π Gap := Trunc(Gap/ShrinkFactor);π IF Gap < 1π THEN Gap := 1π ELSE IF (Gap = 9) OR (Gap = 10)π THEN Gap := 11;π FOR i := Min TO (Max - Gap) DOπ IF Compare(AnArray,i,i+Gap) = 1π THEN BEGINπ Swap(AnArray,i,i+Gap);π Finished := False;π END;π UNTIL ((Gap = 1) AND Finished);πEND;π{****************************************************************************π}{ π }{ CompareπProcedures }{ π }{**********************************π******************************************}FUNCTION CompareChars (VAR πAnArray; Item1, Item2 : LongInt) : Integer;BEGINπ IF CharArray(AnArray)[Item1] < CharArray(AnArray)[Item2]π THEN CompareChars := -1π ELSE IF CharArray(AnArray)[Item1] = CharArray(AnArray)[Item2]π THEN CompareChars := 0π ELSE CompareChars := 1;πEND;π{*****************************************************************************}πFUNCTION CompareInts (VAR AnArray; Item1, Item2 : LongInt) : Integer;πBEGINπ IF IntArray(AnArray)[Item1] < IntArray(AnArray)[Item2]π THEN CompareInts := -1π ELSE IF IntArray(AnArray)[Item1] = IntArray(AnArray)[Item2]π THEN CompareInts := 0π ELSE CompareInts := 1;πEND;π{*****************************************************************************}πFUNCTION CompareLongInts (VAR AnArray; Item1, Item2 : LongInt) : Integer;πBEGINπ IF LongIntArray(AnArray)[Item1] < LongIntArray(AnArray)[Item2]π THEN CompareLongInts := -1π ELSE IF LongIntArray(AnArray)[Item1] = LongIntArray(AnArray)[Item2]π THEN CompareLongInts := 0π ELSE CompareLongInts := 1;πEND;π{*****************************************************************************}πFUNCTION CompareReals (VAR AnArray; Item1, Item2 : LongInt) : Integer;πBEGINπ IF RealArray(AnArray)[Item1] < RealArray(AnArray)[Item2]π THEN CompareReals := -1π ELSE IF RealArray(AnArray)[Item1] = RealArray(AnArray)[Item2]π THEN CompareReals := 0π ELSE CompareReals := 1;πEND;π{*****************************************************************************}πFUNCTION CompareStrs (VAR AnArray; Item1, Item2 : LongInt) : Integer;πBEGINπ IF StrArray(AnArray)[Item1] < StrArray(AnArray)[Item2]π THEN CompareStrs := -1π ELSE IF StrArray(AnArray)[Item1] = StrArray(AnArray)[Item2]π THEN CompareStrs := 0π ELSE CompareStrs := 1;πEND;π{****************************************************************************}π{ }π{ Move Procedures }π{ }π{****************************************************************************}πPROCEDURE MoveChar (VAR AnArray; Item : LongInt; VAR Hold);πBEGINπ Char(Hold) := CharArray(AnArray)[Item];πEND;π{****************************************************************************}π{ }π{ MoveBack Procedures }π{ }π{****************************************************************************}πPROCEDURE MoveBackChar (VAR AnArray; Item : LongInt; VAR Hold);πBEGINπ CharArray(AnArray)[Item] := Char(Hold);πEND;π{****************************************************************************}π{ }π{ Swap Procedures }π{ }π{****************************************************************************}πPROCEDURE SwapChars (VAR AnArray; A, B : LongInt);πVAR Item : Char;πBEGINπ Item := CharArray(AnArray)[A];π CharArray(AnArray)[A] := CharArray(AnArray)[B];π CharArray(AnArray)[B] := Item;πEND;π{*****************************************************************************}πPROCEDURE SwapInts (VAR AnArray; A, B : LongInt);πVAR Item : Integer;πBEGINπ Item := IntArray(AnArray)[A];π IntArray(AnArray)[A] := IntArray(AnArray)[B];π IntArray(AnArray)[B] := Item;πEND;π{*****************************************************************************}πPROCEDURE SwapLongInts (VAR AnArray; A, B : LongInt);πVAR Item : LongInt;πBEGINπ Item := LongIntArray(AnArray)[A];π LongIntArray(AnArray)[A] := LongIntArray(AnArray)[B];π LongIntArray(AnArray)[B] := Item;πEND;π{****************************************************************************}πPROCEDURE SwapPtrs (VAR AnArray; A, B : LongInt);πVAR Item : Pointer;πBEGINπ Item := PtrArray(AnArray)[A];π PtrArray(AnArray)[A] := PtrArray(AnArray)[B];π PtrArray(AnArray)[B] := Item;πEND;π{****************************************************************************}πPROCEDURE SwapReals (VAR AnArray; A, B : LongInt);πVAR Item : Real;πBEGINπ Item := RealArray(AnArray)[A];π RealArray(AnArray)[A] := RealArray(AnArray)[B];π RealArray(AnArray)[B] := Item;πEND;π{*****************************************************************************}πPROCEDURE SwapStrs (VAR AnArray; A, B : LongInt);πVAR Item : String;πBEGINπ Item := StrArray(AnArray)[A];π StrArray(AnArray)[A] := StrArray(AnArray)[B];π StrArray(AnArray)[B] := Item;πEND;π{*****************************************************************************}πBEGINπEND.π
